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.

Gustavo

27 de mayo de 2012