;; Core transformer functions for the compiler-pattern macro. These
;; are stored in a module to ease debugging.

(module pattern-core mzscheme

  (require
   (lib "match.ss")
   "list-utils.ss")

  (provide compiler-patterns-stx)
  
  ;; Other word identifiers, i.e. strings, are converted to symbol
  ;; from syntax. It's ok to use symbols instead of syntax for
  ;; new word names since they have no lexical information attached.
  
  (define (name-stx->symbol stx)
    (syntax-object->datum stx))

  ;; Produce a 'match' clause by reversing in pattern, at compile
  ;; time, and the result of the expression, postponed to runtime.
  ;; Pack the result as (name-symbol . match-clause-stx)
  
  (define (pattern->tagged-match-clause stx)
    (syntax-case stx ()
      (((asm-pattern ... name) expr)
       (cons                              ;; associate the match syntax clause with name tag
        (name-stx->symbol #'name)         
        #`((#,@(reverse                   ;; reverse the pattern list
                (syntax-e                 ;; by peeling off just enough syntax
                 #'(asm-pattern ...)))
            . rest)                       ;; hygienicly introduce 'rest'
           (append/reverse expr rest))))))
  
  ;; Apply the above transformation for all patterns, and collect
  ;; all clauses in a dictionary.
  
  (define (patterns->clause-dict patterns-stx)
    (collect
     (map pattern->tagged-match-clause
          (syntax-e patterns-stx))))


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

  (define (matcher-stx name . clause-stx-list)
    #`(lift-macro-executable
       (lift-transform
        (lambda asm
          (with-handlers
              (((lambda (ex) #t) ;;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 . clause-stx-list)
    (syntax-case namespace ()
      ((ns ...)
       (let ((matcher
              (apply matcher-stx
                     name clause-stx-list)))
         #`(ns-set! '(ns ... #,name)
                    (make-word-compiled
                     '#,name #,matcher))))))
  
  

  ;;       (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 (compiler-patterns-stx stx)
    (syntax-case stx ()
      ((_ namespace . patterns)
       (let ((clause-dict
              (patterns->clause-dict
               #'patterns)))
             
         #`(begin
             #,@(map
                 (lambda (clause)
                   (apply register-stx
                          #'namespace clause))
                 clause-dict))))))
  

  )