racket/collects/macro-debugger/model/reductions.ss

(module reductions mzscheme
  (require (lib "plt-match.ss")
           "stx-util.ss"
           "deriv-util.ss"
           "context.ss"
           "deriv.ss"
           "reductions-engine.ss")

  (provide reductions)

  ;; Setup for reduction-engines

  (define-syntax Expr
    (syntax-id-rules ()
      [Expr (values reductions deriv-e1 deriv-e2)]))
  (define-syntax List
    (syntax-id-rules ()
      [List (values list-reductions lderiv-es1 lderiv-es2)]))
  (define-syntax Block
    (syntax-id-rules ()
      [Block (values block-reductions bderiv-es1 bderiv-es2)]))

  ;; Syntax

  (define-syntax match/with-derivation
    (syntax-rules ()
      [(match/with-derivation d . clauses)
       (let ([dvar d])
         (with-derivation dvar
           (match dvar . clauses)))]))
  
  ;; Reductions

  ;; reductions : Derivation -> ReductionSequence
  (define (reductions d)
    (match/with-derivation d

      ;; Primitives
      [(struct p:variable (e1 e2 rs))
       (if (bound-identifier=? e1 e2)
           null
           (list (walk e1 e2 'resolve-variable)))]
      [(IntQ p:module (e1 e2 rs #f body))
       (with-syntax ([(?module name language . BODY) e1])
         (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]
               [body-e1 (match body [(AnyQ deriv (body-e1 _)) body-e1])])
           (cons (walk e1 (ctx body-e1) 'tag-module-begin)
                 (with-context ctx
                   (reductions body)))))]
      [(IntQ p:module (e1 e2 rs #t body))
       (with-syntax ([(?module name language . BODY) e1])
         (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))])
           (with-context ctx
             (reductions body))))]
      [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2))
       (with-syntax ([(?#%module-begin form ...) e1])
         (let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))])
           (let-values ([(reductions1 final-stxs1)
                         (with-context frame
                           (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))])
             (let-values ([(reductions2 final-stxs2)
                           (with-context frame
                             (mbrules-reductions pass2 final-stxs1 #f))])
               (if (error-wrap? d)
                   (append reductions1 reductions2 
                           (list (stumble (frame final-stxs2) (error-wrap-exn d))))
                   (append reductions1 reductions2))))))]
      [(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni)
       (R e1 _
          [! exni]
          [#:pattern (?define-syntaxes formals RHS)]
          [Expr RHS rhs])]
      [(AnyQ p:define-values (e1 e2 rs rhs) exni)
       (R e1 _
          [! exni]
          [#:pattern (?define-values formals RHS)]
          [#:if rhs
                [Expr RHS rhs]])]
      [(AnyQ p:if (e1 e2 rs full? test then else) exni)
       (if full?
           (R e1 _
              [! exni]
              [#:pattern (?if TEST THEN ELSE)]
              [Expr TEST test]
              [Expr THEN then]
              [Expr ELSE else])
           (R e1 _
              [! exni]
              [#:pattern (?if TEST THEN)]
              [Expr TEST test]
              [Expr THEN then]))]
      [(AnyQ p:wcm (e1 e2 rs key mark body) exni)
       (R e1 _
          [! exni]
          [#:pattern (?wcm KEY MARK BODY)]
          [Expr KEY key]
          [Expr MARK mark]
          [Expr BODY body])]
      [(AnyQ p:begin (e1 e2 rs lderiv) exni)
       (R e1 _
          [! exni]
          [#:pattern (?begin . LDERIV)]
          [List LDERIV lderiv])]
      [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
       (R e1 _
          [! exni]
          [#:pattern (?begin0 FIRST . LDERIV)]
          [Expr FIRST first]
          [List LDERIV lderiv])]
      [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
       (let ([tail
              (R tagged-stx (?#%app . LDERIV)
                 [! exni]
                 [List LDERIV lderiv])])
         (if (eq? tagged-stx e1)
             tail
             (cons (walk e1 tagged-stx 'tag-app) tail)))]
      [(AnyQ p:lambda (e1 e2 rs renames body) exni)
       (R e1 _
          [! exni]
          [#:bind (?formals* . ?body*) renames]
          [#:pattern (?lambda ?formals . ?body)]
          [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
                    #'?formals #'?formals*
                    'rename-lambda]
          [Block ?body body])]
      [(struct p:case-lambda (e1 e2 rs renames+bodies))
       #;
       (R e1 _
          [! exni]
          [#:pattern (?case-lambda [?formals . ?body] ...)]
          [#:bind [(?formals* . ?body*) ...] (map car renames+bodies)]
          [#:rename
           (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))
           (syntax->list #'(?formals ...))
           (syntax->list #'(?formals* ...))
           'rename-case-lambda]
          [Block (?body ...) (map cdr renames+bodies)])
       (with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
                     [((?formals* . ?body*) ...) (map car renames+bodies)])
         (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
           (cons (walk/foci (syntax->list #'(?formals ...))
                            (syntax->list #'(?formals* ...))
                            e1 mid 'rename-case-lambda)
                 (R mid (CASE-LAMBDA [FORMALS . BODY] ...)
                    [Block (BODY ...) (map cdr renames+bodies)]))))]
      [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni)
       (R e1 _
          [! exni]
          [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
          [#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
          [#:rename
           (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
           (syntax->list #'(?vars ...))
           (syntax->list #'(?vars* ...))
           'rename-let-values]
          [Expr (?rhs ...) rhss]
          [Block ?body body])]
      [(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni)
       (R e1 _
          [! exni]
          [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
          [#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
          [#:rename
           (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
           (syntax->list #'(?vars ...))
           (syntax->list #'(?vars* ...))
           'rename-letrec-values]
          [Expr (?rhs ...) rhss]
          [Block ?body body])]
      [(AnyQ p:letrec-syntaxes+values
             (e1 e2 rs srenames srhss vrenames vrhss body) exni)
       (R e1 _
          [! exni]
          [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
          [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames]
          [#:rename
           (syntax/skeleton e1
                            (?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...)
                              . ?body*))
           (syntax->list #'(?svars ...))
           (syntax->list #'(?svars* ...))
           'rename-lsv]
          [Expr (?srhs ...) srhss]
          ;; If vrenames is #f, no var bindings to rename
          [#:if vrenames
                [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
                [#:rename
                 (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...)
                                           ([?vvars** ?vrhs**] ...)
                                        . ?body**))
                 (syntax->list #'(?vvars* ...))
                 (syntax->list #'(?vvars** ...))
                 'rename-lsv]]
          [Expr (?vrhs ...) vrhss]
          [Block ?body body]
          => (lambda (mid)
               (list (walk mid e2 'lsv-remove-syntax))))]
      ;; The auto-tagged atomic primitives
      [(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni)
       (append (if (eq? e1 tagged-stx)
                   null
                   (list (walk e1 tagged-stx 'tag-datum)))
               (if exni
                   (list (stumble tagged-stx (car exni)))
                   null))]
      [(AnyQ p:#%top (e1 e2 rs tagged-stx) exni)
       (append (if (eq? e1 tagged-stx)
                   null
                   (list (walk e1 tagged-stx 'tag-top)))
               (if exni
                   (list (stumble tagged-stx (car exni)))
                   null))]
      
      ;; The rest of the automatic primitives
      [(AnyQ p::STOP (e1 e2 rs) exni)
       (R e1 _
          [! exni])]

      [(AnyQ p:set!-macro (e1 e2 rs deriv) exni)
       (R e1 _
          [! exni]
          => (lambda (mid)
               (reductions deriv)))]
      [(AnyQ p:set! (e1 e2 rs id-rs rhs) exni)
       (R e1 _
          [! exni]
          [#:pattern (SET! VAR RHS)]
          [Expr RHS rhs])]

      ;; Synthetic primitives
      ;; These have their own subterm replacement mechanisms
      [(and d (AnyQ p:synth (e1 e2 rs subterms)))
       (let loop ([term e1] [subterms subterms])
         (cond [(null? subterms) 
                (let ([exn (and (error-wrap? d) (error-wrap-exn d))])
                  (if exn
                      (list (stumble term exn))
                      null))]
               [(s:subterm? (car subterms))
                (let* ([subterm0 (car subterms)]
                       [path0 (s:subterm-path subterm0)]
                       [deriv0 (s:subterm-deriv subterm0)])
                  (let ([ctx (lambda (x) (path-replace term path0 x))])
                    (append (with-context ctx
                              (reductions deriv0))
                            (loop (path-replace term path0 (deriv-e2 deriv0))
                                  (cdr subterms)))))]
               [(s:rename? (car subterms))
                (let* ([subterm0 (car subterms)])
                  ;; FIXME: add renaming steps?
                  ;; FIXME: if so, coalesce?
                  (loop (path-replace term
                                      (s:rename-path subterm0)
                                      (s:rename-after subterm0))
                        (cdr subterms)))]))]

      ;; FIXME
      [(IntQ p:rename (e1 e2 rs rename inner))
       (reductions inner)]

      ;; Error

      ;; Macros
      [(IntQ mrule (e1 e2 transformation next))
       (append (reductions-transformation transformation)
               (reductions next))]

      ;; Lifts
      
      [(IntQ lift-deriv (e1 e2 first lifted-stx second))
       (append (reductions first)
               (list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
               (reductions second))]

      ;; Skipped
      
      [#f null]
      
      #;
      [else (error 'reductions "unmatched case: ~s" d)]))

  ;; reductions-transformation : Transformation -> ReductionSequence
  (define (reductions-transformation tx)
    (match tx
      [(struct transformation (e1 e2 rs me1 me2 locals seq))
       (append (reductions-locals e1 locals)
               (list (walk e1 e2 'macro-step)))]
      [(IntW transformation (e1 e2 rs me1 me2 locals seq) 'locals)
       (reductions-locals e1 locals)]
      [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'bad-transformer exn)
       (list (stumble e1 exn))]
      [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'transform exn)
       (append (reductions-locals e1 locals)
               (list (stumble e1 exn)))]))

  ;; reductions-locals : syntax (list-of LocalAction) -> ReductionSequence
  (define (reductions-locals stx locals)
    (with-new-local-context stx
      (apply append (map reductions-local locals))))

  ;; reductions-local : LocalAction -> ReductionSequence
  (define (reductions-local local)
    (match/with-derivation local
      [(struct local-expansion (e1 e2 me1 me2 deriv))
       (reductions deriv)]
      [(struct local-lift (expr id))
       (list (walk expr id 'local-lift))]
      [(struct local-lift-end (decl))
       (list (walk decl decl 'module-lift))]
      [(struct local-bind (deriv))
       (reductions deriv)]))

  ;; list-reductions : ListDerivation -> ReductionSequence
  (define (list-reductions ld)
    (match/with-derivation ld
      [(IntQ lderiv (es1 es2 derivs))
       (let loop ([derivs derivs] [suffix es1])
         (cond [(pair? derivs)
                (append
                 (with-context (lambda (x) (cons x (stx-cdr suffix)))
                   (reductions (car derivs)))
                 (with-context (lambda (x) (cons (deriv-e2 (car derivs)) x))
                   (loop (cdr derivs) (stx-cdr suffix))))]
               [(null? derivs)
                null]))]
      [(ErrW lderiv (es1 es2 derivs) _ exn)
       (list (stumble es1 exn))]

      [#f null]))

  ;; block-reductions : BlockDerivation -> ReductionSequence
  (define (block-reductions bd)
    (match/with-derivation bd
      ;; If interrupted in pass1, skip pass2
      [(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1)
       (let-values ([(reductions stxs) (brules-reductions pass1 es1)])
         reductions)]
      ;; Otherwise, do both
      [(IntQ bderiv (es1 es2 pass1 trans pass2))
       (let-values ([(reductions1 stxs1) (brules-reductions pass1 es1)])
         (append reductions1
                 (if (eq? trans 'letrec)
                     (match pass2
                       [(AnyQ lderiv (pass2-es1 _ _))
                        (list (walk stxs1 pass2-es1 'block->letrec))])
                     null)
                 (list-reductions pass2)))]
      [#f null]))

  ;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list
  (define (brules-reductions brules all-stxs)
    (let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null])
      (cond [(pair? brules)
             (let ([brule0 (car brules)]
                   [next (cdr brules)])
               (match/with-derivation brule0
                 [(struct b:expr (renames head))
                  (let ([estx (deriv-e2 head)])
                    (loop next (stx-cdr suffix) (cons estx prefix)
                          (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
                                  (reductions head))
                                rss)))]
                 [(IntW b:expr (renames head) tag)
                  (loop next #f #f 
                        (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
                                (reductions head))
                              rss))]
                 [(struct b:defvals (renames head))
                  (let ([head-rs 
                         (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
                           (reductions head))])
                    (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
                          (cons head-rs rss)))]
                 [(AnyQ b:defstx (renames head rhs))
                  (let* ([estx (deriv-e2 head)]
                         [estx2 (with-syntax ([(?ds ?vars ?rhs) estx]
                                              [?rhs* (deriv-e2 rhs)])
                                             ;;FIXME
                                  (datum->syntax-object estx `(,#'?ds ,#'?vars ,#'?rhs*) estx estx))])
                    (loop next (cdr suffix) (cons estx2 prefix)
                          (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
                            (cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs)
                                    (reductions rhs))
                                  (cons (reductions head)
                                        rss)))))]
                 [(struct b:splice (renames head tail))
                  (loop next tail prefix
                        (cons (list (walk/foci (deriv-e2 head)
                                               (stx-take tail
                                                         (- (stx-improper-length tail)
                                                            (stx-improper-length (stx-cdr suffix))))
                                               (revappend prefix 
                                                          (cons (deriv-e2 head) (stx-cdr suffix)))
                                               (revappend prefix tail)
                                               'splice-block))
                              (cons (with-context (lambda (x) 
                                                    (revappend prefix (cons x (stx-cdr suffix))))
                                      (reductions head))
                                    rss)))]
                 [(struct b:begin (renames head derivs))
                  ;; FIXME
                  (error 'unimplemented)]
                 [(struct error-wrap (exn tag _inner))
                  (values (list (stumble/E suffix (revappend prefix suffix) exn))
                          (revappend prefix suffix))]))]
            [(null? brules)
             (values (apply append (reverse rss))
                     (revappend prefix suffix))])))
  
  ;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence
  ;; The reprocess-on-lift? argument controls the behavior of a mod:lift event.
  ;; In Pass1, #t; in Pass2, #f.
  (define (mbrules-reductions mbrules all-stxs reprocess-on-lift?)
    ;(printf "**** MB Reductions, pass ~s~n" (if reprocess-on-lift? 1 2))
    (let* ([final-stxs #f]
           [reductions
            (let loop ([mbrules mbrules] [suffix all-stxs] [prefix null])
              (define (the-context x)
                (revappend prefix (cons x (stx-cdr suffix))))
              (cond [(pair? mbrules)
                     (let ([mbrule0 (car mbrules)]
                           [next (cdr mbrules)])
                       (match/with-derivation mbrule0
                         [(struct mod:skip ())
                          (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
                         [(struct mod:cons (head))
                          (append (with-context the-context (append (reductions head)))
                                  (let ([estx (and (deriv? head) (deriv-e2 head))])
                                    (loop next (stx-cdr suffix) (cons estx prefix))))]
                         [(AnyQ mod:prim (head prim))
                          (append (with-context the-context
                                    (append (reductions head)
                                            (reductions prim)))
                                  (let ([estx (and (deriv? head) (deriv-e2 head))])
                                    (loop next (stx-cdr suffix) (cons estx prefix))))]
                         [(ErrW mod:splice (head stxs) exn)
                          (append (with-context the-context (reductions head))
                                  (list (stumble (deriv-e2 head) exn)))]
                         [(struct mod:splice (head stxs))
                          (append
                           (with-context the-context (reductions head))
                           (let ([suffix-tail (stx-cdr suffix)]
                                 [head-e2 (deriv-e2 head)])
                             (cons (walk/foci head-e2
                                              (stx-take stxs
                                                        (- (stx-improper-length stxs)
                                                           (stx-improper-length suffix-tail)))
                                              (revappend prefix (cons head-e2 suffix-tail))
                                              (revappend prefix stxs)
                                              'splice-module)
                          (loop next stxs prefix))))]
                         [(struct mod:lift (head stxs))
                          (append
                           (with-context the-context (reductions head))
                           (let ([suffix-tail (stx-cdr suffix)]
                                 [head-e2 (deriv-e2 head)])
                             (let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
                               (cons (walk/foci null
                                                stxs
                                                (revappend prefix (cons head-e2 suffix-tail))
                                                (revappend prefix new-suffix)
                                                'splice-lifts)
                                     (loop next
                                           new-suffix
                                           prefix)))))]
                         [(struct mod:lift-end (tail))
                          (append
                           (if (pair? tail)
                               (list (walk/foci null
                                                tail
                                                (revappend prefix suffix)
                                                (revappend prefix tail)
                                                'splice-module-lifts))
                               null)
                           (loop next tail prefix))]))]
                    [(null? mbrules)
                     (set! final-stxs (reverse prefix))
                     null]))])
      (values reductions final-stxs)))
  
  )