(define GSYM-STATE 0)

; ugly hacked gensym
(define (gensym)
  (begin
    (set! GSYM-STATE (add1 GSYM-STATE))
    (string->symbol (++ "GENSYM-GENERATED:" (->string GSYM-STATE)))))

(define-struct syntax (e scopes))

(define (identifier? s) (syntax:syntax? s))

(define (datum->syntax v)
  (cond
    ((syntax:syntax? v) v)
    ((symbol? v) (syntax:make-syntax (->string v) []))
    ((list? v) (map datum->syntax v))
    (else v)))

(define (syntax->datum s)
  (cond
    ((syntax:syntax? s) (string->symbol (syntax:get-e s)))
    ((list? s) (map syntax->datum s))
    (else s)))

(defimpl stringify syntax:syntax?
  ((->string (lambda (v)
    (++ "(syntax "
        (->string (syntax:get-e v))
        " "
        (->string (syntax:get-scopes v))
        ")")))))

(write (->string (datum->syntax '(a b c))))
(write (->string (syntax->datum (datum->syntax '(a b c)))))

(define-struct scope (id))

(define ID 0)

(defimpl stringify scope:scope?
  ((->string (lambda (v)
    (++ "(scope "
        (->string (scope:get-id v))
        ")")))))

(define (scope:new-scope)
  (begin
    (set! ID (+ ID 1))
    (scope:make-scope ID)))

(define (adjust-scope s sc op)
  (cond
    ((syntax:syntax? s) (syntax:make-syntax (syntax:get-e s)
                                            (op (syntax:get-scopes s) sc)))
    ((list? s) (map ($ (adjust-scope % sc op)) s))
    (else s)))

(define (add-scope s sc)
  (adjust-scope s sc ++))

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

(define (set-flip s e)
  (if (in? s e)
    (filter ($ (/= (scope:get-id %) (scope:get-id e))) s)
    (++ s e)))

(write (->string (add-scope (datum->syntax '(a b c)) (scope:new-scope))))
(let ((s (scope:new-scope)))
  (write (->string (flip-scope (add-scope (datum->syntax 'a) s) s))))

(define all-bindings #{})

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

(define (resolve id)
  (define candidate-ids (find-all-matching-bindings id))
  (cond
    ((> (length candidate-ids) 0)
      (begin
        (define max-id (reduce (lambda (x y)
                                (if (< (length (syntax:get-scopes x))
                                       (length (syntax:get-scopes y)))
                                  y
                                  x))
                               (head candidate-ids)
                               (tail candidate-ids)))
        (check-unambiguous max-id candidate-ids)
        (caar (hash:kv-filter ($ (eq? max-id (cadr %))) all-bindings))))
    (else #f)))

(define (find-all-matching-bindings id)
  (hash:values-filter ($ (and (eq? (syntax:get-e %) (syntax:get-e id))
                              (all? (curry in? (syntax:get-scopes id))
                                    (syntax:get-scopes %))))
                      all-bindings))

(define (check-unambiguous max-id candidate-ids)
  (map ($ (unless (all? (curry in? (syntax:get-scopes max-id))
                        (syntax:get-scopes %))
            (error:from-string "ambiguous:" (->string max-id))))
       candidate-ids))

(define core-scope (scope:new-scope))

(define core-forms (list "lambda" "let-syntax" "quote" "quote-syntax"))
(define core-primitives (list "datum->syntax" "syntax->datum" "syntax:get-e"
                              "list" "cons" "head" "cadr" "tail" "map"))

(map ($ (add-binding! (syntax:make-syntax % (list core-scope)) %))
     (++ core-forms core-primitives))

(write (resolve (datum->syntax 'lambda)))
(write (resolve (add-scope (datum->syntax 'lambda) core-scope)))

(define (introduce s)
  (add-scope s core-scope))

(write (->string (introduce (datum->syntax 'cons))))

(define one-prog (introduce (datum->syntax
  '(let-syntax ((one (lambda (stx) (quote-syntax '1))))
      (one)))))

(write (->string one-prog))

(define (env-extend env key val)
  (hash:set env (symbol->string key) val))

(define (env-lookup env binding)
  (env binding))

(define variable (gensym))

(define (expand- s env)
  (cond
    ((identifier? s) (expand-identifier s env))
    ((and (list? s) (> (length s) 0) (identifier? (head s)))
      (expand-id-application-form s env))
    ((list? s) (expand-app s env))
    (else (error:from-string "bad syntax:" s))))

(define (expand stx) (expand- stx #{}))

(define (expand-identifier s env)
  (define binding (resolve s))
  (cond
    ((falsy? binding) (error:from-string "free variable:" s))
    ((in? core-primitives binding) s)
    ((in? core-forms binding) (error:from-string "bad syntax:" s))
    (else
      (define v (env-lookup env binding))
      (cond
        ((eq? v variable) s)
        ((falsy? v) (error:from-string "out of context:" s))
        (else (error:from-string "bad syntax:" s))))))

(define (expand-id-application-form s env)
  (define binding (resolve (head s)))
  (case binding
    (("lambda") (expand-lambda s env))
    (("let-syntax") (expand-let-syntax s env))
    (("quote") s)
    (("quote-syntax") s)
    (else
      (define v (env-lookup env binding))
      (cond
        ((procedure? v) (expand- (apply-transformer v s) env))
        (else (expand-app s env))))))

(define (apply-transformer t s)
  (define intro-scope (scope:new-scope))
  (define intro-s (add-scope s intro-scope))
  (define transformed-s (t intro-s))
  (flip-scope transformed-s intro-scope))

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

(define (expand-lambda s env)
  (begin
    (define lambda-id (car s))
    (define arg-id (caadr s))
    (define body (caddr s))
    (define sc (scope:new-scope))
    (define id (add-scope arg-id sc))
    (define binding (gensym))
    (add-binding! id (symbol->string binding))
    (define body-env (env-extend env binding variable))
    (define exp-body (expand- (add-scope body sc) body-env))
    `(,lambda-id (,id) ,exp-body)))

(define (expand-let-syntax s env)
  (begin
    (define lhs-id (caaadr s))
    (define rhs (car (cdaadr s)))
    (define body (caddr s))
    (define sc (scope:new-scope))
    (define id (add-scope lhs-id sc))
    (define binding (gensym))
    (add-binding! id (symbol->string binding))
    (define rhs-eval (eval-for-syntax-binding rhs))
    (define body-env (env-extend env binding rhs-eval))
    (expand- (add-scope body sc) body-env)))

(define (eval-for-syntax-binding rhs)
  (eval-compiled (compile (expand- rhs #{}))))

(define (compile s)
  (cond
    ((identifier? s) (resolve s))
    (else
      (case (and (identifier? (head s)) (resolve (head s)))
        (("lambda")
          (begin
            (define id (caadr s))
            (define body (caddr s))
            `(lambda (,(resolve id)) ,(compile body))))
        (("quote")
          (begin
            (define datum (cadr s))
            `(quote ,(syntax->datum datum))))
        (("quote-syntax")
          (begin
            (define datum (cadr s))
            `(quote ,datum)))
        (else (map compile s))))))

(define env (make-base-env))

(eval `(define datum->syntax ,datum->syntax) env)
(eval `(define syntax->datum ,syntax->datum) env)
(eval `(define syntax:get-e ,syntax:get-e) env)

(define (eval-compiled s) (eval s env))

(write (syntax->datum (expand one-prog)))