;; Syntax transformer utilities for pattern.ss

(module pattern-tx mzscheme
  (require "tx-utils.ss"
           "list-utils.ss")
  
  (require-for-template mzscheme
                        "ns.ss"
                        "rep.ss"
                        "pattern-runtime.ss"
                        "rpn-snarf.ss"
                        (lib "match.ss"))


  ;; Output assembly is accumulated in reverse on the stack for
  ;; efficiency (cons). The pattern matcher macros will present a
  ;; normal ordering, so they require to reverse both the pattern at
  ;; compile time and the eventual expression at run time. This module
  ;; exports a single function that performs the pattern compilation:

  (provide asm-transforms-stx
           atyped-tx-expr)
  

  
  ;; Forth macros are identified by symbols. Other word identifiers,
  ;; i.e. strings, are converted to symbol from syntax.
  
  (define (name-stx->symbol stx)
    (let ((name (syntax-object->datum stx)))
      (cond
       ((symbol? name) name)
       ((string? name) (string->symbol name))
       (else #f))))


  ;; The core pattern transformer produces a 'match' clause by
  ;; reversing the pattern, at compile time, and the result of the
  ;; expression, postponed to runtime.  Pack the result as
  ;; (name-symbol orig-stx match-clause-stx)
  
;;   (define (pattern->tagged-match-clause stx)
;;     (syntax-case stx ()
;;       (((asm-pattern ... name) expr)
;;        (list                              ;; Associate the match syntax clause with name tag.
;;         (name-stx->symbol #'name)
;;         stx                               ;; Preserve original syntax for debug.
;;         #`((#,@(reverse-stx               ;; Reverse the pattern list
;;                 #'(asm-pattern ...))
;;             . rest)                       ;; hygienicly introduce 'rest'
;;            (append/reverse expr rest))))))

  (define (pattern->name/match-clause stx)
    (syntax-case stx () 
      (((asm-pattern ... name) expr)
       (values 
        (name-stx->symbol #'name)
        #`((#,@(reverse-stx               ;; Reverse the pattern list
                #'(asm-pattern ...))
            . rest)                       ;; hygienicly introduce 'rest'
           (append/reverse expr rest))))))
  
  ;; Apply the above transformation for all patterns, and collect all
  ;; clauses for a single macro. Each item has the form: (orig-stx
  ;; match-clause-stx)
  
  (define (patterns->clause-dict patterns)
    (collect
     (map
      (lambda (stx)
        (let-values
            (((name clause)
              (pattern->name/match-clause
               (atyped->clause stx))))      ;; operate on 'processed' clause (see below)stx)))
          (list name stx clause)))
      patterns)))
  

  ;; Construct syntax for building the matching function. The name
  ;; is only used for error reporting.

  (define (matcher-stx name . clause-stx-list)
    #`(lift-macro               ;; Bring it to correct prototype.
       (lambda asm              ;; We're just matching the asm buffer here.
         (with-handlers         ;; Catch match errors.
             ((exn:misc:match?
               (lambda (ex)
                 (pattern-failed '#,name asm))))
           (match asm
                  #,@clause-stx-list)))))

  ;; Construct syntax for registering + building the matching function.

  (define (register-stx namespace name . orig/clause-list)
    (let
        ((orig-list   (map first  orig/clause-list))
         (clause-list (map second orig/clause-list)))
      (syntax-case namespace ()
        ((ns ...)
         (let ((matcher
                (apply matcher-stx
                       name clause-list)))
           #`(ns-set! '(ns ... #,name)
                      (make-word
                       'asm-match:
                       '#,orig-list
                       #,matcher)))))))
    

  ;; Pattern debugging.
  
  ;;       (define (add-proto-debug protos)
  ;;         (map
  ;;          (match-lambda
  ;;           ((name . clauses)
  ;;            (let ((patterns (map car clauses))) ;; get match patterns

  ;;              (cons name ;; construct debug pattern
  ;;                    (cons
  ;;                     `((['patterns . args] . rest)
  ;;                       (cons '(patterns ,patterns) rest))
  ;;                     clauses)))))
  
  ;;          protos))



  ;; Main transformer.
  
  (define (asm-transforms-stx namespace patterns)
    (let ((clause-dict
           (patterns->clause-dict
            (syntax->list patterns))))
         
      #`(begin
          #,@(map
              (lambda (clause)
                (apply register-stx
                       namespace clause))
              clause-dict))))


  ;; EXTENSION

  ;; I'm trying to implement a syntax akin to algebraic types on top
  ;; of the quite concrete matching syntax. For example:

  ;; (([qw a] [qw b] +)   ([qw (+ a b)]))

  ;; ->

  ;; ((['qw a] ['qw b] +)   `([qw ,(+ a b)]))


  ;; This seems to make a lot of sense since this form of quoting is
  ;; the majority. It cumulated into the construction of the 'asm'
  ;; macro as a driver for atyped-tx-expr.

  ;; The tx-expression is quoted, so unquote can be used to fill in
  ;; opcode names. Use of unquote on the pattern side is there to
  ;; implement "polymorphy". Maybe i should replace both with a more
  ;; explicit expression.

  (define (atyped-tx-pattern stx)
    (->syntax stx
              (map
               (lambda (ins)
                 (syntax-case ins (unquote)
                   (,instruction   #'instruction)
                   ((,tag . args)  #`(tag . args)) 
                   ((tag . args)   #`('tag . args))))
               (syntax->list stx))))

  (define (atyped-tx-expr stx)
    #``#,(->syntax stx
                   (map
                    (lambda (ins)
                      (syntax-case ins (insert)
                        ((insert expr)
                         #`,@expr)
                        ((tag args ...)
                         #`(tag ,args ...))))
                    (syntax->list stx))))

  (define (atyped->clause stx)
    (syntax-case stx ()
      (((arg ... word) expr)
       #`((#,@(atyped-tx-pattern #'(arg ...)) word)
          #,(atyped-tx-expr #'expr)))))
  

;;   ;; DRIVER: call transformer directly -- don't expand to 'compiler-patterns'
;;   (define (asm-transforms-stx namespace patterns)
;;     (compiler-patterns-stx namespace
;;                            (map atyped->clause
;;                                 (syntax->list patterns))))



)