
#lang scheme/base
(require scheme/match
         "stx-util.ss"
         "deriv-util.ss"
         "context.ss"
         "deriv.ss"
         "reductions-engine.ss")

(provide reductions
         reductions+)

;; Reductions

;; reductions : WDeriv -> ReductionSequence
(define (reductions d)
  (let-values ([(steps definites estx exn) (reductions+ d)])
    steps))

;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
(define (reductions+ d)
  (parameterize ((current-definites null)
                 (current-frontier null)
                 (hides-flags (list (box #f)))
                 (sequence-number 0))
    (RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null)
            (lambda (steps stx vstx s)
              (values (reverse steps) (current-definites) vstx #f))
            (lambda (steps exn)
              (values (reverse steps) (current-definites) #f exn)))))

;; Syntax

(define-syntax-rule (match/count x . clauses)
  (begin (sequence-number (add1 (sequence-number)))
         (match x . clauses)))

;; Derivations => Steps

;; Expr : Deriv -> RST
(define (Expr d)
  (match/count d
    [(Wrap deriv (e1 e2))
     (R [#:pattern ?form]
        [#:expect-syntax e1 (list d)]
        [#:when (base? d)
                [#:learn (or (base-resolves d) null)]]
        [#:seek-check]
        [Expr* ?form d]
        [#:when (not (current-pass-hides?))
                [#:set-syntax e2]])]
    [#f
     (R [#:seek-check]
        => (Expr* d))]))

(define (Expr* d)
  (match d
    ;; Primitives
    [(Wrap p:variable (e1 e2 rs ?1))
     (R [#:learn (list e2)]
        [#:when (not (bound-identifier=? e1 e2))
                [#:walk e2 'resolve-variable]])]
    [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
     (R [! ?1]
        [#:pattern (?module ?name ?language . ?body-parts)]
        [! ?2]
        [#:when tag
                [#:in-hole ?body-parts
                           [#:walk (list tag) 'tag-module-begin]]]
        [#:pattern (?module ?name ?language ?body)]
        [#:rename ?body rename]
        [#:when check
                [Expr ?body check]]
        [#:when tag2
                [#:in-hole ?body
                           [#:walk tag2 'tag-module-begin]]]
        [! ?3]
        [Expr ?body body]
        [#:pattern ?form]
        [#:rename ?form shift])]
    [(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
     (R [! ?1]
        [#:pattern ?form]
        [#:rename ?form me]
        [#:pattern (?module-begin . ?forms)]
        [#:pass1]
        [ModulePass ?forms pass1]
        [#:pass2]
        [#:do (DEBUG (printf "** module begin pass 2\n"))]
        [ModulePass ?forms pass2]
        [! ?1])]
    [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
     (R [! ?1]
        [#:pattern (?define-syntaxes formals ?rhs)]
        [Expr/PhaseUp ?rhs rhs]
        [! ?2])]
    [(Wrap p:define-values (e1 e2 rs ?1 rhs))
     (R [! ?1]
        [#:pattern (?define-values ?formals ?rhs)]
        [#:when rhs
                [Expr ?rhs rhs]]
        [#:when (not rhs)
                [#:do (DEBUG (printf "=== end (dvrhs) ===\n"))]
                [#:do (DEBUG (printf "===\n"))]])]
    [(Wrap p:#%expression (e1 e2 rs ?1 inner #f))
     (R [! ?1]
        [#:pattern (?expr-kw ?inner)]
        [Expr ?inner inner])]
    [(Wrap p:#%expression (e1 e2 rs ?1 inner untag))
     (R [! ?1]
        [#:pattern (?expr-kw ?inner)]
        [#:pass1]
        [Expr ?inner inner]
        [#:pattern ?form]
        [#:with-visible-form
         [#:left-foot]
         [#:set-syntax (stx-car (stx-cdr #'?form))]
         [#:step 'macro]]
        [#:pass2]
        [#:set-syntax (stx-car (stx-cdr #'?form))]
        [#:rename ?form untag])]
    [(Wrap p:if (e1 e2 rs ?1 test then else))
     (R [! ?1]
        [#:pattern (?if TEST THEN ELSE)]
        [Expr TEST test]
        [Expr THEN then]
        [Expr ELSE else])]
    [(Wrap p:wcm (e1 e2 rs ?1 key mark body))
     (R [! ?1]
        [#:pattern (?wcm KEY MARK BODY)]
        [Expr KEY key]
        [Expr MARK mark]
        [Expr BODY body])]
    [(Wrap p:begin (e1 e2 rs ?1 lderiv))
     (R [! ?1]
        [#:pattern (?begin . ?lderiv)]
        [List ?lderiv lderiv])]
    [(Wrap p:begin0 (e1 e2 rs ?1 first lderiv))
     (R [! ?1]
        [#:pattern (?begin0 FIRST . LDERIV)]
        [Expr FIRST first]
        [List LDERIV lderiv])]
    [(Wrap p:#%app (e1 e2 rs ?1 lderiv))
     (R [! ?1]
        [#:pattern (?app . LDERIV)]
        [#:if lderiv
              ([List LDERIV lderiv])
              ([#:walk e2 'macro])])]
    [(Wrap p:lambda (e1 e2 rs ?1 renames body))
     (R [! ?1]
        [#:pattern (?lambda ?formals . ?body)]
        [#:rename (?formals . ?body) renames 'rename-lambda]
        [Block ?body body])]
    [(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
     (R [! ?1]
        [#:pattern (?case-lambda . ?clauses)]
        [CaseLambdaClauses ?clauses clauses])]
    [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
     (R [! ?1]
        [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
        [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
        [Expr (?rhs ...) rhss]
        [Block ?body body])]
    [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
     (R [! ?1]
        [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
        [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
        [Expr (?rhs ...) rhss]
        [Block ?body body])]
    [(Wrap p:letrec-syntaxes+values
           (e1 e2 rs ?1 srenames srhss vrenames vrhss body tag))
     (R [! ?1]
        [#:pass1]
        [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
        [#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body)
                   srenames
                   'rename-lsv]
        [BindSyntaxes (?srhs ...) srhss]
        ;; If vrenames is #f, no var bindings to rename
        [#:when vrenames
                [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
        [Expr (?vrhs ...) vrhss]
        [Block ?body body]
        [#:pass2]
        [#:pattern ?form]
        [#:when tag
                [#:walk tag 'lsv-remove-syntax]])]
    [(Wrap p:#%datum (e1 e2 rs ?1))
     (R [! ?1]
        [#:hide-check rs]
        [#:walk e2 'macro])]
    [(Wrap p:#%top (e1 e2 rs ?1))
     (R [! ?1]
        [#:pattern (?top . ?var)]
        [#:learn (list #'?var)])]

    [(Wrap p:provide (e1 e2 rs ?1))
     (R [! ?1]
        [#:walk e2 'provide])]

    [(Wrap p:stop (e1 e2 rs ?1))
     (R [! ?1])]

    ;; The rest of the automatic primitives
    [(Wrap p::STOP (e1 e2 rs ?1))
     (R [! ?1])]

    [(Wrap p:set!-macro (e1 e2 rs ?1 deriv))
     (R [! ?1]
        [#:pattern ?form]
        [Expr ?form deriv])]
    [(Wrap p:set! (e1 e2 rs ?1 id-rs rhs))
     (R [! ?1]
        [#:pattern (?set! ?var ?rhs)]
        [#:learn id-rs]
        [Expr ?rhs rhs])]

    ;; Macros
    [(Wrap mrule (e1 e2 rs ?1 me1 locals me2 ?2 etx next))
     (R [! ?1]
        [#:pattern ?form]
        [#:hide-check rs]
        [#:learn rs]
        [#:pass1]
        [#:left-foot]
        [#:rename/mark ?form e1 me1] ;; MARK
        [LocalActions ?form locals]
        [! ?2]
        [#:pass2]
        [#:set-syntax me2]
        [#:rename/unmark ?form me2 etx] ;; UNMARK
        [#:step 'macro]
        [#:set-syntax etx]
        [Expr ?form next])]

    [(Wrap tagrule (e1 e2 tagged-stx next))
     (R [#:pattern ?form]
        [#:hide-check (list (stx-car tagged-stx))]
        [#:walk tagged-stx
                (case (syntax-e (stx-car tagged-stx))
                  ((#%app) 'tag-app)
                  ((#%datum) 'tag-datum)
                  ((#%top) 'tag-top)
                  (else
                   (error 'reductions "unknown tagged syntax: ~s" tagged-stx)))]
        [Expr ?form next])]

    ;; Lifts

    [(Wrap lift-deriv (e1 e2 first lifted-stx second))
     (R [#:pattern ?form]
        ;; lifted-stx has form (begin lift-n ... lift-1 orig-expr)
        [#:let mid-stxs (reverse (stx->list (stx-cdr lifted-stx)))]
        [#:let lifted-def-stxs (cdr mid-stxs)]
        [#:let main-stx (car mid-stxs)]
        [#:parameterize ((available-lift-stxs lifted-def-stxs)
                         (visible-lift-stxs null))
          [#:pass1]
          [Expr ?form first]
          [#:do (when (pair? (available-lift-stxs))
                  (error 'lift-deriv "available lifts left over"))]
          [#:let begin-stx (stx-car lifted-stx)]
          [#:with-visible-form
           ;; If no lifts visible, then don't show begin-wrapping
           [#:when (pair? (visible-lift-stxs))
                   [#:walk (datum->syntax lifted-stx
                                          `(,begin-stx ,@(visible-lift-stxs) ,#'?form)
                                          lifted-stx
                                          lifted-stx)
                           'capture-lifts]]]
          [#:pass2]
          [#:set-syntax lifted-stx]
          [Expr ?form second]])]

    [(Wrap lift/let-deriv (e1 e2 first lifted-stx second))
     (R [#:pattern ?form]
        ;; lifted-stx has form
        ;; (let-values ((last-v last-lifted))
        ;;   ...
        ;;     (let-values ((first-v first-lifted)) orig-expr))
        [#:let first-e2 (wderiv-e2 first)]
        [#:let lift-stxs (take-lift/let-stxs lifted-stx first-e2)]
        [#:parameterize ((available-lift-stxs lift-stxs)
                         (visible-lift-stxs null))
          [#:pass1]
          [Expr ?form first]
          [#:do (when (pair? (available-lift-stxs))
                  (error 'lift/let-deriv "available lifts left over"))]
          [#:let visible-lifts (visible-lift-stxs)]
          [#:with-visible-form
           [#:left-foot]
           [#:set-syntax (reconstruct-lift/let-stx visible-lifts #'?form)]
           [#:step 'capture-lifts]]
          [#:pass2]
          [#:set-syntax lifted-stx]
          [Expr ?form second]])]

    ;; Skipped
    [#f
     (R)]))

(define (take-lift/let-stxs lifted-stx base)
  (let loop ([lifted-stx lifted-stx] [acc null])
    (if (eq? lifted-stx base)
        acc
        (with-syntax ([(?let ?binding ?inner) lifted-stx])
          (loop #'?inner (cons (list #'?let #'?binding) acc))))))
(define (reconstruct-lift/let-stx lifts base)
  (if (null? lifts)
      base
      (datum->syntax base
                     `(,@(car lifts) ,(reconstruct-lift/let-stx (cdr lifts) base)))))

;; Expr/PhaseUp : Deriv -> RST
(define (Expr/PhaseUp d)
  (R [#:parameterize ((phase (add1 (phase))))
     => (Expr* d)]))

;; case-lambda-clauses-reductions : 
;;   (list-of (W (list ?exn rename (W BDeriv)))) stxs -> RST
(define (CaseLambdaClauses clauses)
  (match/count clauses
    ['()
     (R)]
    [(cons (Wrap clc (?1 rename body)) rest)
     (R [! ?1]
        [#:pattern ((?formals . ?body) . ?rest)]
        [#:rename (?formals . ?body) rename 'rename-case-lambda]
        [Block ?body body]
        [CaseLambdaClauses ?rest rest])]))

;; local-actions-reductions
(define (LocalActions locals)
  (match locals
    ['()
     (R)]
    [(cons local rest)
     (R [#:pattern ?form]
        [#:if (visibility)
              ;; If macro with local-expand is transparent,
              ;; then all local-expansions must be transparent.
              ([#:parameterize ((macro-policy (lambda _ #t)))
                 [#:new-local-context
                  [LocalAction ?form local]]])
              ([#:pass1]
               [LocalAction ?form local]
               [#:pass2])]
        [LocalActions ?form rest])]))

(define (LocalAction local)
  (match/count local
    [(struct local-expansion (e1 e2 for-stx? me1 inner #f me2 opaque))
     (R [#:do (when opaque
                (fprintf (current-error-port)
                         "LocalAction: local-expand-expr\n"))]
        [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))))
         [#:set-syntax e1]
         [#:pattern ?form]
         [#:rename/mark ?form e1 me1]
         [Expr ?form inner]
         [#:rename/mark ?form me2 e2]])]
    [(struct local-expansion (e1 e2 for-stx? me1 inner lifted me2 opaque))
     (R [#:do (when opaque
                (fprintf (current-error-port)
                         "LocalAction: not handling opaque val\n"))]
        [#:let begin-stx (stx-car lifted)]
        [#:let lift-stxs (cdr (reverse (stx->list (stx-cdr lifted))))]
        [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase)))
                         (available-lift-stxs lift-stxs)
                         (visible-lift-stxs null))
         [#:set-syntax e1]
         [#:pattern ?form]
         [#:rename/unmark ?form e1 me1]
         [#:pass1]
         [Expr ?form inner]
         [#:do (when (pair? (available-lift-stxs))
                 (error 'local-expand/capture-lifts "available lifts left over"))]
         [#:let visible-lifts (visible-lift-stxs)]
         [#:with-visible-form
          [#:left-foot]
          [#:set-syntax (datum->syntax lifted
                                       `(,begin-stx ,@visible-lifts ,#'?form)
                                       lifted lifted)]
          [#:step 'splice-lifts visible-lifts]]
         [#:pass2]
         [#:set-syntax lifted]
         [#:rename/mark ?form me2 e2]])]
    [(struct local-lift (expr id))
     ;; FIXME: add action
     (R [#:do (unless (pair? (available-lift-stxs))
                (error 'local-lift "out of lifts!"))
              (when (pair? (available-lift-stxs))
                (let ([lift-d (car (available-lift-stxs))]
                      [lift-stx (car (available-lift-stxs))])
                  (when (visibility)
                    (visible-lift-stxs (cons lift-stx (visible-lift-stxs))))
                  (available-lift-stxs (cdr (available-lift-stxs)))))]
        [#:reductions (list (walk expr id 'local-lift))])]
    [(struct local-lift-end (decl))
     ;; (walk/mono decl 'module-lift)
     (R)]
    [(struct local-bind (names ?1 renames bindrhs))
     [R [! ?1]
        ;; FIXME: use renames
        [#:when bindrhs => (BindSyntaxes bindrhs)]]]))

;; List : ListDerivation -> RST
(define (List ld)
  (match ld
    [(Wrap lderiv (es1 es2 ?1 derivs))
     (R [! ?1]
        [#:pattern (?form ...)]
        [Expr (?form ...) derivs])]
    [#f
     (R)]))

;; Block  : BlockDerivation -> RST
(define (Block bd)
  (match/count bd
    [(Wrap bderiv (es1 es2 pass1 trans pass2))
     (R [#:pattern ?block]
        [#:parameterize ((block-syntax-bindings null)
                         (block-value-bindings null)
                         (block-expressions null))
          [#:pass1]
          [BlockPass ?block pass1]
          [#:pass2]
          [#:when (eq? trans 'letrec)
                  [#:walk
                   (let* ([pass2-stxs (wlderiv-es1 pass2)]
                          [letrec-form (car pass2-stxs)]
                          [letrec-kw (stx-car letrec-form)]
                          [stx-bindings (reverse (block-syntax-bindings))]
                          [val-bindings (reverse (block-value-bindings))]
                          [exprs (block-expressions)]
                          [mk-letrec-form (lambda (x) (datum->syntax #f x))])
                     (list
                      (mk-letrec-form
                       `(,letrec-kw ,@(if (pair? stx-bindings)
                                          (list stx-bindings)
                                          null)
                                    ,val-bindings
                                    . ,exprs))))
                   'block->letrec]]
          [#:rename ?block (wlderiv-es1 pass2)]
          [#:set-syntax (wlderiv-es1 pass2)]
          [List ?block pass2]])]
    [#f
     (R)]))

;; BlockPass : (list-of BRule) -> RST
(define (BlockPass brules)
  (match/count brules
    ['()
     (R)]
    [(cons (Wrap b:error (exn)) rest)
     (R [! exn])]
    [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
     (R [#:pattern (?first . ?rest)]
        [#:rename/no-step ?first (car renames) (cdr renames)]
        [#:pass1]
        [Expr ?first head]
        [! ?1]
        [#:pass2]
        [#:let begin-form #'?first]
        [#:let rest-forms #'?rest]
        [#:pattern ?forms]
        [#:left-foot (list begin-form)]
        [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)]
        [#:step 'splice-block (stx->list (stx-cdr begin-form))]
        [#:rename ?forms tail]
        [! ?2]
        [#:pattern ?forms]
        [BlockPass ?forms rest])]

    ;; FIXME: are these pass1/2 necessary?

    [(cons (Wrap b:defvals (renames head ?1 rename ?2)) rest)
     (R [#:pattern (?first . ?rest)]
        [#:rename/no-step ?first (car renames) (cdr renames)]
        [#:pass1]
        [Expr ?first head]
        [! ?1]
        [#:pass2]
        [#:pattern ((?define-values . ?clause) . ?rest)]
        [#:rename ?clause rename]
        [! ?2]
        [#:do (block-value-bindings
               (cons #'?clause (block-value-bindings)))]
        [#:pattern (?first . ?rest)]
        [BlockPass ?rest rest])]
    [(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest)
     (R [#:pattern (?first . ?rest)]
        [#:rename/no-step ?first (car renames) (cdr renames)]
        [#:pass1]
        [Expr ?first head]
        [! ?1]
        [#:pass2]
        [#:pattern ((?define-syntaxes . ?clause) . ?rest)]
        [#:rename ?clause rename]
        [! ?2]
        [#:do (block-syntax-bindings
               (cons #'?clause (block-syntax-bindings)))]
        [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
        [BindSyntaxes ?rhs bindrhs]
        [#:pattern (?first . ?rest)]
        [BlockPass ?rest rest])]
    [(cons (Wrap b:expr (renames head)) rest)
     (R [#:pattern (?first . ?rest)]
        [#:rename/no-step ?first (car renames) (cdr renames)]
        [Expr ?first head]
        [#:do (block-expressions #'(?first . ?rest))]
        ;; rest better be empty
        [BlockPass ?rest rest])]

    ))

;; BindSyntaxes : BindSyntaxes -> RST
(define (BindSyntaxes bindrhs)
  (match bindrhs
    [(Wrap bind-syntaxes (rhs ?1))
     (R [#:pattern ?form]
        [Expr/PhaseUp ?form rhs]
        [! ?1])]))

;; ModulePass : (list-of MBRule) -> RST
(define (ModulePass mbrules)
  (match/count mbrules
    ['()
     (R)]
    [(cons (Wrap mod:prim (head rename prim)) rest)
     (R [#:pattern (?firstP . ?rest)]
        [Expr ?firstP head]
        [#:do (DEBUG (printf "** after head\n"))]
        [#:rename ?firstP rename]
        [#:do (DEBUG (printf "** after rename\n"))]
        [#:when prim
                [Expr ?firstP prim]]
        [#:do (DEBUG (printf "** after prim\n"))]
        [ModulePass ?rest rest])]
    [(cons (Wrap mod:splice (head rename ?1 tail)) rest)
     (R [#:pattern (?firstB . ?rest)]
        [#:pass1]
        [Expr ?firstB head]
        [#:rename ?firstB rename]
        [! ?1]
        [#:pass2]
        [#:let begin-form #'?firstB]
        [#:let rest-forms #'?rest]
        [#:pattern ?forms]
        [#:left-foot (list #'?firstB)]
        [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)]
        [#:step 'splice-module (stx->list (stx-cdr begin-form))]
        [#:rename ?forms tail]
        [ModulePass ?forms rest])]
    [(cons (Wrap mod:lift (head renames stxs)) rest)
     (R [#:pattern (?firstL . ?rest)]
        ;; renames has form (head-e2 . ?rest)
        ;; stxs has form (lifted ...), specifically (last-lifted ... first-lifted)
        [#:parameterize ((available-lift-stxs (reverse stxs))
                         (visible-lift-stxs null))
          [#:pass1]
          [Expr ?firstL head]
          [#:do (when (pair? (available-lift-stxs))
                  (error 'mod:lift "available lifts left over"))]
          [#:let visible-lifts (visible-lift-stxs)]
          [#:pattern ?forms]
          [#:pass2]
          [#:when renames
                  [#:rename ?forms renames]]
          [#:let old-forms #'?forms]
          [#:left-foot null]
          [#:set-syntax (append visible-lifts old-forms)]
          [#:step 'splice-lifts visible-lifts]
          [#:set-syntax (append stxs old-forms)]
          [ModulePass ?forms rest]])]
    [(cons (Wrap mod:lift-end (stxs)) rest)
     (R [#:pattern ?forms]
        [#:when (pair? stxs)
                [#:left-foot null]
                [#:set-syntax (append stxs #'?forms)]
                [#:step 'splice-module-lifts stxs]]
        [ModulePass ?forms rest])]
    [(cons (Wrap mod:skip ()) rest)
     (R [#:pattern (?firstS . ?rest)]
        [ModulePass ?rest rest])]
    [(cons (Wrap mod:cons (head)) rest)
     (R [#:pattern (?firstC . ?rest)]
        [Expr ?firstC head]
        [ModulePass ?rest rest])]))
