Macros by Example in Typed Racket

macros_by_example.md

Macros By Example in Typed Racket

Based on ftp://www.cs.indiana.edu/pub/techreports/TR206.pdf

(Yep people still have FTP servers out there...)

NO HYGIENE. NO LITERALS.

Just matches a sexp and expands it (once.)

Some things don't work...

Double ellipsis in template

> ((make-expander
    '((x ...) ...)
    '(x ... ...))
   '((a b) (c d) (e f)))
template-instantiate: missing ellipsis in template x #(struct:ellipsis-matches (a b))
> (bind-pattern '((x ...) ...) '((a b) (c d) (e f)))
- : (U Env False)
(hasheq
 'x
 (ellipsis-matches
  (list
   (ellipsis-matches '(a b))
   (ellipsis-matches '(c d))
   (ellipsis-matches '(e f)))))
>

More stuff after ellipsis

> ((make-expander '(y x ...) '(x ... y)) '(1 2 3 4))
- : (U False Sexp)
'(2 3 4)
;; should be '(2 3 4 1)

mbe.rkt

#lang typed/racket/base

(define-type Pattern
  (U Symbol Null (Pairof Pattern Pattern) (List Pattern '...)))

(define-type Sexp
  (U Symbol Number Null (Pairof Sexp Sexp)))

(define-predicate sexp? Sexp)

(define-type Level Nonnegative-Integer)

(struct ellipsis-matches
  ([ls : (Listof Pattern-Binding)])
  #:type-name Ellipsis-Matches
  #:transparent)

(: ellipsis-matches-length (Ellipsis-Matches -> Nonnegative-Integer))
(define (ellipsis-matches-length em)
  (length (ellipsis-matches-ls em)))

(define-type Pattern-Binding
  (U Sexp Ellipsis-Matches))

(define-type Env
  (Immutable-HashTable Symbol Pattern-Binding))

(: env-union (Env Env -> Env))
(define (env-union e0 e1)
  (for/fold ([e0 : Env e0]) ([(k v) (in-hash e1)])
    (hash-set e0 k v)))

(: combine-env ((Listof Env) -> Env))
(define (combine-env e*)
  (if (null? e*)
      (hasheq)
      (for/fold ([e : Env (hasheq)]) ([(k v) (in-hash (car e*))])
        (hash-set e k (ellipsis-matches
                       (for/list : (Listof Pattern-Binding) ([e (in-list e*)])
                         (hash-ref e k)))))))

(: prune-env (Env (Listof Symbol) -> Env))
(define (prune-env e0 s*)
  (for/fold ([e : Env (hasheq)]) ([s (in-list s*)])
    (hash-set e s (hash-ref e0 s))))

(: env-ellipsis-same-lengths (Env -> (Option Nonnegative-Integer)))
(define (env-ellipsis-same-lengths e)
  (let/ec break : (Option Nonnegative-Integer)
    (for/fold ([l : (Option Nonnegative-Integer) #f]) ([v (in-hash-values e)])
      (if (ellipsis-matches? v)
          (let* ([l0 (ellipsis-matches-length v)]
                 [l1 (or l l0)])
            (if (= l0 l1)
                l0
                (break #f)))
          l))))

(: transpose-sexp
   (Nonnegative-Integer
    (Listof (Listof Pattern-Binding))
    ->
    (Listof (Listof Pattern-Binding))))
(define (transpose-sexp i xs*)
  (cond
    [(zero? i) null]
    [else
     (let-values ([(xs xs*)
                   (for/fold ([xs : (Listof Pattern-Binding) null]
                              [xs* : (Listof (Listof Pattern-Binding)) null])
                             ([x (in-list (reverse xs*))])
                     (values (cons (car x) xs)
                             (cons (cdr x) xs*)))])
       (cons xs (transpose-sexp (sub1 i) xs*)))]))

(: decompose-env (Env -> (Listof Env)))
(define (decompose-env e)
  ;; Split environment into level 0 and everything else
  (define-values (e0 k* xs*)
    (for/fold
     ([e0 : Env (hasheq)]
      [k* : (Listof Symbol) null]       
      [xs* : (Listof (Listof Pattern-Binding)) null])
     ([(k v) (in-hash e)])
      (if (sexp? v)
          (values (hash-set e0 k v) k* xs*)
          (values e0
                  (cons k k*)                    
                  (cons (ellipsis-matches-ls v
                         #;(assert v ellipsis-matches?))
                        xs*)))))

  ;; Transpose ellipsis values to spread across envs
  (define txs*
    (transpose-sexp
     (assert (env-ellipsis-same-lengths e))
     xs*))
  
  (for/list : (Listof Env) ([v* (in-list txs*)])
    (for/fold : Env ([e : Env e0]) ([v (in-list v*)]
                                    [k (in-list k*)])
      (hash-set e k v))))
  
(: free-vars (Pattern -> (Listof Symbol)))
(define (free-vars p)
  (: free-vars-acc (Pattern (Listof Symbol) -> (Listof Symbol)))
  (define (free-vars-acc p a)
    (cond
      [(null? p) a]
      [(symbol? p) (cons p a)]
      [(ellipsis-pattern? p) (free-vars-acc (car p) a)]
      [(pair? p) (free-vars-acc (cdr p) (free-vars-acc (car p) a))]
      [else
       (error 'free-vars "unknown pattern:" p)]))
  (free-vars-acc p null))

(: ellipsis-pattern? (Pattern -> Boolean))
(define (ellipsis-pattern? p)
  (and (pair? p)
       (pair? (cdr p))
       (eq? '... (cadr p))))

(: bind-pattern (Pattern Sexp -> (Option Env)))
(define (bind-pattern p s)
  (cond
    [(null? p) (and (null? s) (hasheq))]
    
    [(symbol? p) (hasheq p s)]

    [(ellipsis-pattern? p) (and (list? s)
                                (if (null? s)
                                    (for/hash : Env
                                        ([i (in-list (free-vars (car p)))])
                                      (values i (ellipsis-matches null)))
                                    (bind-pattern* (car p) s)))]
    
    [(pair? p) (and (pair? s)
                    (let ([e0 (bind-pattern (car p) (car s))]
                          [e1 (bind-pattern (cdr p) (cdr s))])
                      (and e0 e1 (env-union e0 e1))))]
    
    [else
     (error 'bind-pattern "unknown pattern:" p)]))

(: bind-pattern* (Pattern (Listof Sexp) -> (Option Env)))
(define (bind-pattern* p s*)
  (let ([e* (let/ec break : (Option (Listof Env))
              (for/list : (Listof Env) ([s (in-list s*)])
                (or (bind-pattern p s) (break #f))))])
    (and e* (combine-env e*))))

(: template-instantiate (Pattern Env -> Sexp))
(define (template-instantiate p e)
  (cond
    [(null? p) p]
    
    [(symbol? p) (let ([r : Pattern-Binding
                          (hash-ref e p (lambda () p))])
                   (if (sexp? r)
                       r
                       (error 'template-instantiate
                              "missing ellipsis in template"
                              p r)))]
    
    [(ellipsis-pattern? p) (template-instantiate*
                            (car p) (prune-env e (free-vars (car p))))]

     
    [(pair? p) (cons (template-instantiate (car p) e)
                     (template-instantiate (cdr p) e))]
    [else
     (error 'template-instantiate "unknown template:" p)]))

(: template-instantiate* (Pattern Env -> (Listof Sexp)))
(define (template-instantiate* p e)
  (for/list : (Listof Sexp) ([e (in-list (decompose-env e))])
    (template-instantiate p e)))

(: make-expander (Pattern Pattern -> (Sexp -> (Option Sexp))))
(define (make-expander p t)
  (lambda (s)
    (let ([e (bind-pattern p s)])
      (and e (template-instantiate t e)))))