sid.rkt

#lang racket

(provide (all-defined-out))

#|
(define x ...)

(define-syntax (premade-or e)
  (or e x))

(define-syntax (premade-or-2 e)
  (let ([y e]) 
    (or y x)))

(let ([x (quote 5)]) sc1
  (let ([y (quote 10)]) sc2
    (premade-or-2 x))) (sc1 sc2)
|#

#|
L
<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
|#

#|
(define-syntax (premade-or-2 e)
  (let ([y e]) ; sc3
    (or y x)))

(let ([x (quote 5)])    ; sc1
  (let ([y (quote 10)]) ; sc2
    (premade-or-2 x)))  ; x -> (sc1 sc2), y -> (sc2)
=>
(let ([x (quote 5)])    ; sc1
  (let ([y (quote 10)]) ; sc1, sc2
    (let ([y y])        ; (car y) -> sc1, sc2, sc3, (cdr y) -> sc3
      (or y x))))
|#

; binding as set of scopes
(struct syntax (e scopes))

; helpers: identifer?, datum->syntax, syntax->datum
(define identifer? syntax?)
(define (datum->syntax s)
  (syntax s (set)))
(define (syntax->datum s)
  (syntax-e s))

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

; Either syntax (list syntax) -> (set scope -> scope ->  (set scope)) -> scope -> Either syntax (list syntax)
(define (adjust-scope expr op sc)
  (cond
    [(identifier? expr) (syntax (syntax-e expr) (op (syntax-scopes expr) sc))]
    [(list? expr) (map (lambda (e) (adjust-scope e op sc)) expr)]
    [else (error "Invalid adjust-scope call")]))

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

(define (flip-scope expr sc) (adjust-scope expr set-flip sc))
(define (add-scope expr sc) (adjust-scope expr set-add sc))

; global binding table: add-binding!, resolve
; (syntax -> gensym'd symbol)
(define all-bindings (make-hash))

(define (add-binding! id sym) (hash-set! all-bindings id sym))

; (let ([a a-rhs])   (a sc1) -> loc/a
;   (let ([b b-rhs]) (a sc1) (b sc1 sc2)
;     body))         (a sc1 sc2) -> loc/a

; (let ([c ...]) body) (sc1) -> loc/c1
; (let ([c ...]) body) (sc2) -> loc/c2
; resolve (syntax 'c (sc1 sc2)) => error
; resolve (syntax 'c (sc1)) => loc/c1
; resolve (syntax 'c (sc2)) => loc/c2
(define (resolve id)
  (let ([candidate-bindings (get-candidate-bindings id)])
    (let ([max-binding (argmax (compose set-count syntax-scopes) candidate-bindings)])
      (if (ambiguous? max-binding candidate-bindings)
        (error "Bad resolution")
        (hash-ref all-bindings max-binding)))))

(define (get-candidate-bindings id)
  (filter (lambda (cid)
            (and (eq? (syntax-e id) (syntax-e cid))
                 (subset? (syntax-scopes cid)
                     (syntax-scopes id))))
          (hash-keys all-bindings)))

(define (ambiguous? max-binding candidate-bindings)
  (let ([sz (set-count (syntax-scopes max-binding))])
    (not (= 1 (length (filter (lambda (c-bind)
                                (= sz (set-count (syntax-scopes c-bind))))
                              candidate-bindings))))))
  
; core-scope, core-forms, core-primitives, add-scope
(define core-scope (scope))
(define core-forms '(lambda quote let-syntax quote-syntax))
(define core-primitives '(datum->syntax syntax->datum cons car cdr pair? syntax-e))
(map (lambda (core-x)
       (add-binding! core-x (gensym core-x)))
     (append core-forms core-primitives))

; empty-env, variable, env-extend, env-lookup, add-local-binding!
(define empty-env (make-hash))
(define (env-extend env key val) (hash-set env key val))
(define (env-lookup env key) (hash-ref env key #f))

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

; expand, expand-identifier, expand-id-app, apply-transformer, expand-lambda,
(define (expand expr [env empty-env])
  (cond
    ; (lambda (x) *x*)
    [(identifier? expr) (expand-identifier x env)]
    ; (core-form ...)
    ; (let-syntax ([id rhs]) body)
    ; (lambda (id) body)
    ; (quote-syntax datum)
    ; (quote datum)
    ; ((lambda (x) (mf x)) (quote 5))
    ; (mf ...)
    [(pair? expr)
     (case (car expr)
       [(let-syntax) (expand-let-syntax expr env)]
       [(lambda) (expand-lambda expr env)]
       [(quote quote-syntax) expr]
       [else (let ([expanded-car (expand (car expr) env)]
                   [expanded-cdr (expand (cdr expr) env)])
               (if (procedure? expanded-car)
                 (apply-transformer expanded-car expanded-cdr env)
                 (cons expanded-car expanded-cdr)))])]
    [(null? expr)
     expr]
    [else (error "Unable to expand")]))

(define (expand-identifier id env)
  (let ([binding (resolve id)])
    (let ([val (env-lookup env id)])
      (cond
        [(not val) (error "Out of scope: " id)]
        [(eq? 'variable val) id]
        [else (error "Unable to expand identifier: " id)]))))

; new-scope is attached to only those identifier that are introduced by mf
(define (apply-transformer mf t env)
  (let ([new-scope (scope)])
    (let ([t (add-scope t new-scope)])
      (let ([expanded (mf t)])
        (flip-scope expanded new-scope)))))

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

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

(define (compile expr)
  (case (car expr)
    [(lambda)
     (match-define `(lambda (,id) ,body) expr)
     (let ([arg (resolve id)])
       `(lambda (,arg) ,(compile body)))]
    [(quote)
     (match-define `(quote ,datum) expr)
     `(quote ,(syntax-e datum))]
    [(quote-syntax)
     (match-define `(quote ,datum) expr)
     `(quote ,datum)]
    [(list? expr) (map compile expr)]
    [(identifier? expr)
     (resolve expr)]))

(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))