27 de mayo de 2012

Adding the syntax for negate in Racket

Introduction

One of the things I like about arc is that it has a little of syntax, which helps shorten the length of the programs. In particular, ~ indicates the negated version of a function.
For example:
(equal? 1 1) ; ==> #t
(~equal? 1 1) ; ==> #f
(equal? 1 2) ; ==> #f
(~equal? 1 2) ; ==> #t
Adding this to Racket is not straightforward. You need to create a readtable and then grouped with the necessary code that is easy to use as if it were part of a predefined language indicated with #lang.

Creating a readtable for ~

Let's start by creating the readtable, which is the part that has the more specific code in this example. Let's put all these files in a directory called neg.
File: neg/main.rkt (version 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))))))])}
The function make-neg-read-table is used to create the new readtable in which when a ~ is found, the function neg-parse is called. The main part is neg-parse that transforms ~something into (negate something). It has two variants, one for calls from the read function and one for calls from the read-syntax. The rest of the code is necessary to call it using #reader.
We can test this using #reader. The downside of using #reader is that it only reads one expression, so we have to enclose everything in a begin. Also negate is not defined in racket/base, so we have to remember to import it from racket/function.
File: 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
]

The name of ~equal?

The problem is that the function created by ~equal? doesn’t have a nice name.
File: 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>

It could be fixed using procedure-rename, but instead of that we will create a function using lambda directly and choose the name using the 'inferred-name property. This version has its advantages and disadvantages because it fixes the name problem, but does not work with keyword arguments and it is not optimized for functions with 1 or 2 arguments. It is possible to make a version that fixes all the details, but is against the goal that ~ produce only a simple transformation.
File: 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)))])}

Why ~equal? is not equal? to ~equal? ?

Another detail is that each time that ~equal? runs, it creates a new function, so they are all different. I would like that all the functions are really one, because the expression (equal? ~equal? ~equal?) looks like a #t, but so far all the solutions I came up are too long and destroy Racket optimizer.
File: neg/test3.rkt
#lang racket/base
(require (only-in racket/function negate))

#reader "main.rkt"
[begin
  (equal? equal? equal?) ; ==> #t
  (equal? ~equal? ~equal?) ; ==> #f :(
  (let ([tmp equal?]) (equal? tmp tmp)) ; ==> #t
  (let ([tmp ~equal?]) (equal? tmp tmp)) ; ==> #t
  ]

Extending a language with neg/neg-exp

To use this extension a simple way, we will create a language neg/neg-exp that adds ~ to any language. To define this language, the first step is to create the correct directory structure and register it as a collection. For this step it is important that the directory where these files are located is named (for example) neg. To register the collection, we must go to the directory containing the directory neg and run the command raco link neg. This directory must contain the file neg/main.rkt. In this directory you must create the necessary subdirectories to finally create the file neg/neg-exp/lang/reader.rkt.
File: 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)])}})}
This file is almost a direct copy of the file that defines at-exp in Racket with the obvious changes. The only important change is that at-exp uses its own color-lexer to color code after using the syntax check button, but in this example it is not necessary so we just use the original language coloration.
Now we can use this with any language, for example racket or racket/base. The good news is you do not need enclose the entire program in one begin. Moreover, with neg registered as a collection, this extension can be called from any file, no matter the relative position of the directories in which they are located.
File: 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
One important detail is that the functions read and read-syntax are those of the original language (i.e. they do not consider ~ in a special way). Also no additional definitions from neg/neg-exp are included, so we have to included explicitly negate if it is necessary.

Languages neg/neg and racket/racket/base

The two languages that we most likely want to use extended with ~ are racket and racket/base, so it is worth creating the combinations as independent languages. Let's see how to do this for neg/racket/base. For that we must create the correct subdirectory structure and two files.
First we create the file that defines the language. It is the same that racket/base, but if we add negate just in case it is needed and we will use the functions read and read-syntax from neg, no the original of racket/base.
File: 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)
Then we create the file that makes possible to use it as a language. Almost all the hard work it done by syntax/module-reader. First we indicate that we use to neg/racket/base as the main language, and next we indicate that for reading the code we will use the versions of read and read-syntax coming from neg and not those of the original racket/base.
File: 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)
Now we use it as a regular language.
File: 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
For the way that we build the new language, the functions read and read-syntax that are used to read the code and the used while running the code recognize a special way ~. This is not mandatory, but it seemed the most natural choice.
The same process can be used to create neg/racket, making the obvious changes.

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.