macros-as-staging.rkt

#lang racket

(struct lit [v] #:transparent)
(struct lam [xs e] #:transparent)
(struct ref [x] #:transparent)
(struct app [e1 e2] #:transparent)
(struct quot [e] #:transparent)
(struct unquot [e] #:transparent)
(struct lif [c t e] #:transparent)
(struct run [e])
(struct fix [f])

(struct rep [e] #:transparent)
(struct clo [xs e env] #:transparent)

(struct prim [proc] #:transparent)

(struct bind [phase val])

(define (ext-env* env vars vals)
  (for/fold ([env env])
            ([var vars]
             [val vals])
    (hash-set env var val)))

(define gensym
  (let ([ctr 0])
    (λ (sym)
      (define init (symbol->string sym))
      (define base (car (string-split init "-")))
      (set! ctr (+ ctr 1))
      (string->symbol (string-append base "-" (number->string ctr))))))

(define (eval exp env)
  (match exp
    [(lit v)
     v]
    [(ref x)
     (match-define (bind (or 0 'all) b-v)
       (hash-ref env x (lambda () (error 'eval "unbound reference ~a" x))))
     b-v]
    [(lam xs e)
     (clo xs e env)]
    [(app e1 es)
     (lapply (eval e1 env)
             (map (λ (e) (eval e env)) es))]
    [(lif c t e)
     (if (eval c env)
         (eval t env)
         (eval e env))]
    [(quot e)
     (rep (stage e env 1))]
    [(run e)
     (match-define (rep e2) (eval e env))
     (eval e2 env)]))

(define (lapply f args)
  (match f
    [(clo xs b c-env)
     (when (not (= (length xs) (length args)))
       (error 'lapply "wrong number of arguments to ~a" f))
     (eval b (ext-env* c-env xs (map (λ (v) (bind 0 v)) args)))]
    [(prim proc)
     (apply proc args)]))

(define (stage exp env ph)
  (match exp
    [(lit v)
     (lit v)]
    [(ref x)
     (match-define (bind b-ph b-v) (hash-ref env x))
     (cond
       [(equal? 'all b-ph)
        (ref x)]
       [(= ph b-ph)
        (ref b-v)]
       [else
        (error 'stage "variable not in phase: ~a" x)])]
    [(lam xs e)
     (define gs (map gensym xs))
     (lam gs (stage e (ext-env* env xs (map (λ (g) (bind ph g)) gs)) ph))]
    [(app e1 es)
     (app (stage e1 env ph)
          (map (λ (e) (stage e env ph)) es))]
    [(lif c t e)
     (lif (stage c env ph) (stage t env ph) (stage e env ph))]
    [(quot e)
     (quot (stage e env (+ ph 1)))]
    [(run e)
     (run (stage e env ph))]
    [(unquot e)
     (if (= (- ph 1) 0)
         (let ()
           (match-define (rep v) (eval e env))
           v)
         (unquot (stage e env (- ph 1))))]))

(struct parser-var [stx])
(struct parser-stx [proc])

(define (parse exp env)
  (match exp
    [(or (? number?) #t #f)
     (lit exp)]
    [`(,'quote ,e)
     (lit e)]
    [(? symbol?)
     (when (not (parser-var? (hash-ref env exp #f)))
       (error 'parse "not bound to variable: ~a ~a" exp (hash-ref env exp #f)))
     (parser-var-stx (hash-ref env exp #f))]
    [`(lambda (,(? symbol? xs) ...) ,e)
     ; Needed? Or do I get it all from the runtime?
     ;(define gs (map (λ (v) (gensym v)) xs))
     ; if so gs below instead of xs
     (lam xs (parse e (ext-env* env xs (map (λ (v) (parser-var (ref v))) xs))))]
    [`(if ,c ,t ,e)
     (lif (parse c env) (parse t env) (parse e env))]
    [`(,'quasiquote ,e)
     (quot (parse e env))]
    [`(,'unquote ,e)
     (unquot (parse e env))]
    [`(run ,e)
     (run (parse e env))]
    [`(let-syntax ,x ,fstx ,body)
     (define f (eval (parse fstx env) prim-env))
     (parse body (hash-set env x (parser-stx f)))]
    [`(,x . ,rest)
     #:when (parser-stx? (hash-ref env x #f))
     (rep-e (lapply (parser-stx-proc (hash-ref env x)) (list exp env)))]
    [`(,e1 ,es ...)
     (app (parse e1 env) (map (λ (e) (parse e env)) es))]))

(define prim-info
  (list
   (cons 'car car)
   (cons 'cdr cdr)
   (cons 'cadr cadr)
   (cons '- -)
   (cons '* *)
   (cons '+ +)
   (cons '/ /)
   (cons 'map (lambda (f l) (map (λ (i) (lapply f (list i))) l)))
   (cons 'null? null?)
   (cons 'list? list?)
   (cons 'box box)
   (cons 'unbox unbox)
   (cons 'set-box! set-box!)
   (cons 'symbol? symbol?)
   (cons 'list list)
   (cons 'select (lambda (sexp path)
                   (let loop ([sexp sexp]
                              [path path])
                     (if (null? path)
                         sexp
                         (loop (list-ref sexp (car path)) (cdr path))))))
   (cons 'equal? equal?)
   (cons 'ext-env (lambda (env v val) (hash-set env v (parser-var (rep-e val)))))
   (cons 'debug (lambda (v) (displayln v) v))
   (cons 'parse  (lambda (exp env) (rep (parse exp env))))))

(define prim-env
  (make-immutable-hash
   (map (λ (p) (cons (car p) (bind 'all (prim (cdr p)))))
        prim-info)))

(define prim-parser-env
  (make-immutable-hash
   (map (λ (p) (cons (car p) (parser-var (ref (car p)))))
        prim-info)))

(define (p e) (parse e prim-parser-env))
(define (ev e) (eval (parse e prim-parser-env) prim-env))

(module+ test
  (require rackunit)
  

  (check-equal? (ev '((lambda (x y) y) 4 5))
                5)

  (check-equal? (ev '`5)
                (rep (lit 5)))

  (check-equal? (ev '(run `5))
                5)

  (check-equal? (ev '((run ((lambda (y) `(lambda (x) ,y)) `5)) 6))
                5)

  ; hygiene 
  (check-equal? (ev '(((run `(lambda (x)
                               ,((lambda (y)
                                   `(lambda (x)
                                      ,y))
                                 `x)))
                       1)
                      2))
                1)

  ; primitives
  (check-equal? (ev '(if #t (car '(a b)) 'b))
                'a)


  (define res
   (ev '(let-syntax let (lambda (stx env)
                         `((lambda (v)
                             ,(parse (select stx '(2))
                                     (ext-env env (select stx '(1 0 0)) `v)))
                           ,(parse (select stx '(1 0 1)) env)))
         (let-syntax or (lambda (stx env)
                          `(let ([tmp ,(parse (select stx '(1)) env)])
                             (if tmp
                                 tmp
                                 ,(parse (select stx '(2)) env))))
           (let-syntax begin2 (lambda (stx env)
                                `(let ([tmp ,(parse (select stx '(1)) env)])
                                   ,(parse (select stx '(2)) env)))
             (let-syntax letrec (lambda (stx env)
                                  (let ([name (select stx '(1 0 0))])
                                    (let ([f (select stx '(1 0 1))])
                                      (let ([body (select stx '(2))])
                                        `(let ([t (box #f)])
                                           (begin2
                                             (set-box! t ,(parse f (ext-env env name `(unbox t))))
                                             ,(parse body (ext-env env name `(unbox t)))))
                                        ))))
               (let-syntax let (lambda (stx env)
                                 (let ([body (select stx '(2))])
                                   (letrec ([rec (lambda (bindings env^)
                                                   (if (null? bindings)
                                                       (parse body env^)
                                                       `(let ([t ,(parse (select bindings '(0 1)) env)])
                                                          ,(rec (cdr bindings) (ext-env env^ (select bindings '(0 0)) `t)))))])
                                     (rec (select stx '(1)) env))))
                 (let-syntax let* (lambda (stx env)
                                    (let ([body (select stx '(2))])
                                      (letrec ([rec (lambda (bindings env^)
                                                      (if (null? bindings)
                                                          (parse body env^)
                                                          `(let ([t ,(parse (select bindings '(0 1)) env^)])
                                                             ,(rec (cdr bindings) (ext-env env^ (select bindings '(0 0)) `t)))))])
                                        (rec (select stx '(1)) env))))
                   (let-syntax letl (lambda (stx env)
                                      (let ([loop-id (select stx '(1))]
                                            [vars (map car (select stx '(2)))]
                                            [inits (map cadr (select stx '(2)))]
                                            [body (select stx '(3))])
                                        `(letrec ([f ,(letrec ([rec (lambda (vars env^)
                                                                      (if (null? vars)
                                                                          (parse body env^)
                                                                          `(lambda (v)
                                                                             ,(rec (cdr vars)
                                                                                (ext-env env^ (car vars) `v)))))])
                                                        (rec vars (ext-env env loop-id `f)))])
                                           ,(letrec ([rec (lambda (inits acc)
                                                            (if (null? inits)
                                                                acc
                                                                (rec (cdr inits) `(,acc ,(parse (car inits) env)))
                                                                ))])
                                              (rec inits `f)))))
                     (let-syntax for/fold (lambda (stx env)
                                            (let ([accvar (select stx '(1 0 0))]
                                                  [accinit (select stx'(1 0 1))]
                                                  [lvar (select stx '(2 0 0))]
                                                  [linit (select stx '(2 0 1))]
                                                  [body (select stx '(3))])
                                              `(letl rec ([acc ,(parse accinit env)]
                                                          [l ,(parse linit env)])
                                                     (if (null? l)
                                                         acc
                                                         ; TODO: letl isn't quite right; I have to call rec curried. Don't know how to fix.
                                                         ((rec (let ([i (car l)])
                                                                 ,(parse body (ext-env (ext-env env accvar `acc)
                                                                                       lvar `i))))
                                                          (cdr l))))))
                       (list
                        (letrec ([fact (lambda (n)
                                         (if (equal? 0 n)
                                             1
                                             (* n (fact (- n 1)))))])
                          (fact 5))
                   
                        (let* ([x 5]
                               [y 6]
                               [z (+ x y)])
                          z)

                        (letl fact ([n 5])
                              (if (equal? 0 n)
                                  1
                                  (* n (fact (- n 1)))))

                        (for/fold ([sum 0])
                                  ([i '(1 2 3)])
                          (+ sum i))
                   
                        (let ([tmp 5])
                          (let ([v #f])
                            (begin2
                              (debug 5)
                              (or v tmp))))

                        `(lambda (stx env)
                           `(let ([tmp ,(parse (select stx '(1)) env)])
                              (if tmp
                                  tmp
                                  ,(parse (select stx '(2)) env))))
                        )))))))))))
  (pretty-write res)
  (lapply (eval (rep-e (sixth res)) prim-env) (list '(or #f #t) prim-parser-env))
  )