reconstruction.rkt

#lang racket
#|
- Mention that we're writing expander, the interpreter comes later
- Show example with let-syntax
|#

#|
<expr> ::= (lambda (<id>) <expr>)      ; procedure
         | <id>                        ; variable
         | (<expr> ... <expr>)         ; procedure call
         | (quote <datum>)             ; literal data
         | (let-syntax ([<id> <expr>]) ; macro binding
             <expr>)
         | (quote-syntax <datum>)      ; literal syntax

(quote '(lambda (x) x)) => list
(quote-syntax '(lambda (x) x)) => syntax (datum, syntactic info)

(let-syntax ([one (lambda (stx)
                    (quote-syntax (quote 1)))])
  (one))
=> (quote 1)
|#

; binding as set of scopes
(struct syntax (e scopes) #:transparent)

; helpers: identifer?, datum->syntax, syntax->datum
(define identifer? syntax?)
(define (datum->syntax d)
  (cond
    [(syntax? d) d]
    [(symbol? d) (syntax d (set))]
    [(list? d) (map datum->syntax d)]
    [else d]))
(define (syntax->datum s)
  (cond
    [(syntax? s) (syntax-e s)]
    [(list? s) (map syntax->datum s)]
    [else s]))

; scope & helpers: adjust-scope (add, flip)
(struct scope ())

(define (add-scope id sc)
  (syntax (syntax-e id) (set-add (syntax-scopes id) sc)))

(define (adjust-scope id op sc)
  (syntax (syntax-e id) (op (syntax-scopes id) sc)))

(define (flip-scope id sc)
  (adjust-scope id set-flip sc))

(define (set-flip s e)
  (if (set-member? s e) (set-remove s e) (set-add s e)))

; eq?
; (let ([x ...])   // sc1
;   (let ([y ...]) // sc2
;     ...))

; global binding table: add-binding!, resolve
(define all-bindings (make-hash))
(define (add-binding! id b)
  (hash-set! all-bindings id b))

(define (resolve id)
  (let ([candidate-bindings (find-all-matching-bindings id)])
    (if (null? candidate-bindings)
      #f
      (let ([max-id (argmax (compose set-count syntax-scopes) candidate-bindings)])
        (if (ambiguous? max-id candidate-bindings)
          (error "Ambiguous binding")
          (hash-ref all-bindings max-id))))))

(define (find-all-matching-bindings id)
  (filter (lambda (binding)
            (subset? (syntax-scopes binding) (syntax-scopes id)))
          (hash-keys bindings)))

(define (ambiguous? max-id candidate-bindings)
  (or (null? candidate-bindings)
      (let ([c-bind (car candidate-bindings)]
            [candidate-bindings (cdr candidate-bindings)])
        (and (subset? (syntax-scopes c-bind) (syntax-scopes max-id))
             (ambiguous? max-id candidate-bindings)))))

#|
(let ([a ...])   // sc1, loc/a
  body)          // (syntax 'a (set sc1))

(let ([a ...])   // sc1, loc/a
  (let ([z ...]) // sc2  loc/z
    body))       // (syntax 'a (set sc1 sc2))
(resolve (syntax 'a (set sc1 sc2))) -> loc/a

(let ([b ...])   // sc1 loc/b1 
  (let ([b ...]) // sc2 loc/b2 (syntax 'b (set sc1))
    body))       // (syntax 'b (set sc1 sc2))
(resolve (syntax 'b (set sc1 sc2))) -> loc/b2
? Why not throw away older scopes for each identifer?

(let ([c ...]) body1) // sc1 loc/c1
(let ([c ...]) body2) // sc2 loc/c2
? Give an example of a macro which triggers ambiguous
(resolve (syntax 'c (set sc1 sc2))) -> error
binding table
c -> (set sc1 sc2 sc3)
c -> (set sc1 sc2)
c -> (set sc4)
|#

; core-scope, core-forms, core-primitives, add-scope
(define core-scope (scope))
(define core-forms (seteq lambda quote let-syntax quote-syntax))
(define core-primitives (seteq datum->syntax syntax->datum cons car cdr list syntax-e))
(for ([sym (in-set (set-union core-forms core-primitives))])
     (add-binding! sym (syntax sym (set core-scope))))

; empty-env, variable, env-extend, env-lookup, add-local-binding!
(define empty-env (hasheq))
(define variable (gensym 'variable))
(define (env-extend env id proc)
  (hash-set env id proc))
(define (env-lookup env id)
  (hash-ref env id #f))

(define (add-local-binding! id)
  (let ([bind (gensym (syntax-e id))])
    (add-binding! id bind)
    bind))

(define (expand s [env empty-env])
  (cond
    ; (lambda (x) *x*)
    [(identifer? s) (expand-identifier s env)]
    ; (x ...)
    [(and (pair? s)
          (identifer? s))
     (expand-id-app s env)]
    ; ((curried f) ...)
    [(or (pair? s)
         (null? s))
     (expand-app s env)]
    [else (error "Unable to expand")]))

(define (expand-identifier s env)
  (let ([binding (resolve s)])
    (cond
      [(not binding) (error "Unbound symbol")]
      [(member? core-forms binding) (error "Syntax error")]
      [(member? core-primitives binding) s]
      [else
        (let ([v (env-lookup env s)])
         (cond
          [(not v) (error "Out of context variable")]
          [(eq? v 'variable) s]
          [else (error "Bad syntax")]))])))

(define (expand-id-app s env)
  (case (car s)
    [(quote-syntax) s]
    [(lambda) (expand-lambda s env)]
    [(let-syntax) (expand-let-syntax s env)]
    [(quote quote-syntax) s]
    [else
      (let ([binding (resolve (car s))])
        (let ([v (env-lookup env binding)])
          (cond
            [(procedure? v) (expand (apply-transformer v s) env)]
            [else (expand-app s env)])))]))

(define (apply-transformer t s)
  (let ([newscope (scope)])
    (let ([scoped-s (add-scope s newscope)])
      (let ([transformed-s (t s)])
        (flip-scope transformed-s newscope)))))

(define (expand-lambda s env)
  (match-define `(lambda (,arg) ,body) s)
  (let ([new-scope (scope)])
    (let ([arg (add-scope arg new-scope)])
      (let ([binding (add-local-binding! arg)])
        (let ([new-env (env-extend env binding 'variable)])
          (let ([expanded-body (expand (add-scope body new-scope) new-env)])
            `(lambda (,arg) ,expanded-body)))))))

(define (expand-let-syntax s env)
  (match-define `(let-syntax ([,id ,rhs]) ,body) s)
  (define new-scope (scope))
  (define id (add-scope id new-scope))
  (define binding (add-local-binding! id))
  (define rhs-val (eval-compiled (compile (expand rhs env))))
  (define new-env (env-extend env id rhs-val))
  (expand (add-scope body new-scope) new-env))

(define (expand-app s env)
  (map (lambda (se) (expand se env)) s))

(define (compile s)
  (cond
    [(pair? s)
     (let ([core-sym (and (identifier? s) (resolve (car s)))])
       (case core-sym
         [(lambda)
          (match-define `(lambda (,id) ,body) s)
          `(lambda (,(resolve id)) ,(compile body))]
         [(quote)
          (match-define `(quote ,d) s)
          `(quote ,(syntax->datum d))]
         [(quote-syntax)
          (match-define `(quote-syntax ,s))
          `(quote ,s)]
         [else
          (map compile s)]))]
    [(identifier? s)
     (resolve s)]
    [else (error "Bad syntax after expansion: " s)]))

(define namespace (make-base-namespace))
(namespace-set-variable-value! 'datum->syntax datum->syntax #t namespace)
(namespace-set-variable-value! 'syntax->datum syntax->datum #t namespace)
(namespace-set-variable-value! 'syntax-e syntax-e #t namespace)

(define (eval-compiled s)
  (eval s namespace))