Agregando sintaxis para negate en Racket

Introducción

Una de las cosas que me gustan de arc es que tiene un poquito de sintaxis, que ayuda a acortar la longitud de los programas. En particular, con ~ se indica la versión negada de una función.

Por ejemplo:

(equal? 1 1) ; ==> #t
(~equal? 1 1) ; ==> #f
(equal? 1 2) ; ==> #f
(~equal? 1 2) ; ==> #t

Agregarle esto a Racket no es un proceso directo. Es necesario crear una readtable y luego agruparla con el código necesario que sea fácil de usar como si fuera parte de un lenguaje predefinido con #lang.

Creando una readtable para ~

Empecemos por crear la readtable, que es la parte que tiene el código más específico de este ejemplo. Vamos a poner todos estos archivos en un nuevo directorio llamado neg.

Archivo: neg/main.rkt (versión 1)

#lang racket/base
 
(provide (rename-out (neg-read read) (neg-read-syntax read-syntax)))
  
{define (neg-read in) 
  (parameterize ([current-readtable (make-neg-readtable)]) 
    (read in))}
  
{define (neg-read-syntax src in) 
  (parameterize ([current-readtable (make-neg-readtable)]) 
    (read-syntax src in))}
  
{define (make-neg-readtable) 
  (make-readtable (current-readtable) 
                  #\~ 'non-terminating-macro neg-parse)} 
  
{define neg-parse 
  (case-lambda 
    [(ch port) ; for read
     (let ([next (read/recursive port #f)])
       `(negate ,next))] 
    [(ch port src line col pos) ; for read-syntax 
     (let ([next (read-syntax/recursive src port #f)])
       (datum->syntax 
        #f 
        `(negate ,next)
        (let-values ([(l c p) (port-next-location port)]) 
          (list src line col pos (and pos (- p pos))))))])}

La función make-neg-read-table sirve para crear la nueva readtable en la que al encontrar un ~ se ejecuta neg-parse. La parte principal está en neg-parse que transforma ~algo en (negate algo). Tiene dos variantes, una para cuando se la llama desde la función read y otra para las llamadas desde la función read-syntax. El resto del código sirve para poder usarlo con #reader.
Podemos probar esto usando #reader. Lo malo de usar este ejemplo con #reader es que sólo lee una expresión, así que tenemos que encerrar todo lo que queremos leer en un begin. Además como la función negate no está en racket/base, hay que recordar importarla desde racket/function.

Archivo: neg/test1.rkt

#lang racket/base
(require (only-in racket/function negate))

#reader "main.rkt"
[begin
  (equal? 1 1) ; ==> #t
  (~equal? 1 1) ; ==> #f
  (equal? 1 2) ; ==> #f
  (~equal? 1 2) ; ==> #t
  ({lambda (x) (equal? x 0)} 0) ; ==> #t
  (~{lambda (x) (equal? x 0)} 0) ; ==> #f
  ({lambda (x) (equal? x 0)} 1) ; ==> #f
  (~{lambda (x) (equal? x 0)} 1) ; ==> #t
]

El nombre de ~equal?

El problema de la versión 1 es que la función creada por ~equal? no tiene un lindo nombre.

Archivo: neg/test2.rkt

#lang racket/base
(require racket/function)

#reader "main.rkt"
[begin
  (displayln equal?) ; ==> #
  (displayln ~equal?) ; ==> #<...ket function.rkt:36:11=""> :(
  equal? ; ==> #
  ~equal? ; ==> #<...ket function.rkt:36:11=""> :(
]</...ket></...ket>

Se podría arreglar usando procedure-rename, pero en vez de eso vamos crear la función directamente con lambda y ponerle el nombre usando la propiedad 'inferred-name. Esta versión tiene sus ventajas y desventajas porque arregla los nombres, pero no funciona con argumentos con keywords y no está optimizada para funciones con 1 ó 2 argumentos. Hacer una versión que arregle todos los detalles es posible, pero está en contra de la idea de que ~ produzca sólo una transformación simple.

Archivo: neg/main.rkt (versión 2)

#lang racket/base
 
(provide neg-read neg-read-syntax make-neg-readtable
         (rename-out [neg-read read] 
                     [neg-read-syntax read-syntax])) 
  
{define (neg-read in) 
  (parameterize ([current-readtable (make-neg-readtable)]) 
    (read in))}
  
{define (neg-read-syntax src in) 
  (parameterize ([current-readtable (make-neg-readtable)]) 
    (read-syntax src in))}
  
{define (make-neg-readtable) 
  (make-readtable (current-readtable) 
                  #\~ 'non-terminating-macro neg-parse)} 
  
{define neg-parse 
  (case-lambda 
    [(ch port) 
     (let ([next (read/recursive port #f)])
       `(#%expression {lambda args (not (apply ,next args))}))]
    [(ch port src line col pos) 
     (let ([next (read-syntax/recursive src port #f)])
       (let ([stx (datum->syntax 
                   #f 
                   `(#%expression {lambda args (not (apply ,next args))})
                  (let-values ([(l c p) (port-next-location port)]) 
                    (list src line col pos (and pos (- p pos)))))])
         (if (identifier? next)
             (syntax-property stx
                              'inferred-name
                              (string->symbol (string-append (list->string (list ch)) (symbol->string (syntax-e next)))))
             stx)))])}

¿Por que ~equal? no es equal? a ~equal? ?

Otro detalle es que en cada ejecución ~equal? crea una nueva función, así que son todas distintas. Me gustaría que fueran iguales porque al mirar (equal? ~equal? ~equal?) dan ganas de que sea #t, pero hasta ahora las soluciones que se me ocurrieron son largas y destruyen el optimizador de Racket.

Archivo: neg/test3.rkt

#lang racket/base
 
(provide neg-read neg-read-syntax make-neg-readtable
         (rename-out [neg-read read] 
                     [neg-read-syntax read-syntax])) 
  
{define (neg-read in) 
  (parameterize ([current-readtable (make-neg-readtable)]) 
    (read in))}
  
{define (neg-read-syntax src in) 
  (parameterize ([current-readtable (make-neg-readtable)]) 
    (read-syntax src in))}
  
{define (make-neg-readtable) 
  (make-readtable (current-readtable) 
                  #\~ 'non-terminating-macro neg-parse)} 
  
{define neg-parse 
  (case-lambda 
    [(ch port) 
     (let ([next (read/recursive port #f)])
       `(#%expression {lambda args (not (apply ,next args))}))]
    [(ch port src line col pos) 
     (let ([next (read-syntax/recursive src port #f)])
       (let ([stx (datum->syntax 
                   #f 
                   `(#%expression {lambda args (not (apply ,next args))})
                  (let-values ([(l c p) (port-next-location port)]) 
                    (list src line col pos (and pos (- p pos)))))])
         (if (identifier? next)
             (syntax-property stx
                              'inferred-name
                              (string->symbol (string-append (list->string (list ch)) (symbol->string (syntax-e next)))))
             stx)))])}

Extendiendo un lenguaje con neg/neg-exp

Para poder usar esta extensión de una manera sencilla, vamos a crear un lenguaje neg/neg-exp que agregue ~ a un lenguaje cualquiera.
Para ello es necesario como primer paso crear la estructura de directorios correcta y registrarlo como una colección. Al directorio principal donde están estos archivos lo llamamos (por ejemplo) neg. Para registrar la colección hay que ir al directorio que contiene al directorio neg y ejecutar el comando raco link neg. En este directorio tiene que estar el archivo neg/main.rkt y además hay que crear los subdirectorios necesarios para tener el archivo neg/neg-exp/lang/reader.rkt.

Archivo: neg/neg-exp/lang/reader.rkt

#lang racket/base
(require syntax/module-reader
         (only-in neg make-neg-readtable))

(provide (rename-out [neg-read read]
                     [neg-read-syntax read-syntax]
                     [neg-get-info get-info]))

(require (only-in racket/function negate))
(provide negate)

{define (wrap-reader p)
  (lambda args
    (parameterize ([current-readtable (make-neg-readtable)])
      (apply p args)))}

{define-values (neg-read neg-read-syntax neg-get-info)
  (make-meta-reader
   'neg-exp
   "language path"
   {lambda (str)
     (let ([s (string->symbol
               (string-append (bytes->string/latin-1 str)
                              "/lang/reader"))])
       (and (module-path? s) s))}
   wrap-reader
   wrap-reader
   {lambda (proc)
     {lambda (key defval)
       (case key
         #;[(color-lexer)
            (dynamic-require 'syntax-color/scheme-lexer 'scheme-lexer)]
         [else (if proc (proc key defval) defval)])}})}

El archivo es una copia casi directa del archivo que define at-exp de Racket con los cambios obvios. El único cambio importante es que at-exp utiliza su propio color-lexer para colorear el código al usar el botón de chequear sintaxis. Pero para este ejemplo no hace falta, así que simplemente usamos la coloración del lenguaje inicial.
Ahora podemos usar neg-exp con un lenguaje cualquiera, por ejemplo racket o racket/base. Lo bueno es que ya no hace falta encerrar todo el programa en un solo begin. Además, al haber registrado a neg como una colección, se puede llamar a esta extensión desde cualquier archivo, sin importan la posición relativa de los directorios en que están localizados.

Archivo: neg/test4.rkt

#lang neg/neg-exp racket/base
(require (only-in racket/function negate))

(equal? 1 1) ; ==> #t
(~equal? 1 1) ; ==> #f
(equal? 1 2) ; ==> #f
(~equal? 1 2) ; ==> #t
({lambda (x) (equal? x 0)} 0) ; ==> #t
(~{lambda (x) (equal? x 0)} 0) ; ==> #f
({lambda (x) (equal? x 0)} 1) ; ==> #f
(~{lambda (x) (equal? x 0)} 1) ; ==> #t

Un detalle importante es que las funciones read y read-syntax son las del lenguaje original (o sea que no consideran a ~ de manera especial). Además tampoco están incluidas las definiciones adicionales presentes en neg/neg-exp por lo que hay que incluir explícitamente a negate si hace falta.

Lenguajes neg/racket y neg/racket/base

Los dos lenguajes que más probablemente uno quiere usar extendidos con ~ son racket y racket/base, por lo que vale la pena crear las combinaciones como lenguajes independientes. Veamos como hacer esto para neg/racket/base. Para eso hay que crear la estructura de subdirectorios correcta y dos archivos.
Primero creamos el archivo que define el lenguaje. Este lenguaje es igual que racket/base, pero le agregamos negate por si hace falta. Además vamos a usar las funciones read y read-syntax definidas en neg y no las originales de racket/base.

Archivo: neg/racket/base.rkt

#lang racket/base
(require "../main.rkt")
(require (only-in racket/function negate))

(provide (all-from-out racket/base)
         read read-syntax negate)

Después creamos el archivo para que podamos usarlo como un lenguaje. Casi todo el trabajo lo hace syntax/module-reader. Primero indicamos que vamos usar a neg/racket/base como lenguaje principal, y después que para leer el código vamos a usar las versiones de read y read-syntax que vienen de neg y no las de las originales de racket/base.

Archivo: neg/racket/base/lang/reader.rkt

#lang s-exp syntax/module-reader
neg/racket/base

#:read read 
#:read-syntax read-syntax 

#:language-info '#(racket/language-info get-info #f)

(require neg)

Ahora lo podemos usar como un lenguaje cualquiera.

Archivo: neg/test5.rkt

#lang neg/racket/base

(equal? 1 1) ; ==> #t
(~equal? 1 1) ; ==> #f
(equal? 1 2) ; ==> #f
(~equal? 1 2) ; ==> #t
({lambda (x) (equal? x 0)} 0) ; ==> #t
(~{lambda (x) (equal? x 0)} 0) ; ==> #f
({lambda (x) (equal? x 0)} 1) ; ==> #f
(~{lambda (x) (equal? x 0)} 1) ; ==> #t

Por como armamos el nuevo lenguaje, las funciones read y read-syntax que usa para leer el código y las que usa mientras se ejecuta reconocen a ~ de manera especial. Esto no es obligatorio, pero me pareció lo más natural.
El mismo proceso se puede usar para crear neg/racket, haciendo los cambios obvios.

Gustavo

27 de mayo de 2012