#lang scheme/base
;; Syntax transformer utilities for pattern.ss


(require
 "../ns-tx.ss"
 "../tools.ss"
 "../op/static.ss"
 scheme/pretty
 (for-template
  scheme/base
  "../op.ss"
  "../tools.ss"
  "../scat.ss"
  "../ns.ss"
  "pattern-runtime.ss"
  "rep.ss"
  scheme/match
  ;; (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-pattern-tx
 asm-template-tx
 asm-lambda-tx
 asm-transforms-tx
 with-asm-transforms-tx
 )


;; The core pattern transformer produces a 'match' clause by reversing
;; the pattern, at compile time for the matcher macro to use, and the
;; result of the expression, postponed to runtime.  Pack the result as
;; (name-symbol match-clause-tx)

;; Pattern/Template syntax.

;; This is a layer on top of the 'raw' pattern syntax that assumes all
;; list elements referred in pattern and template have a tag symbol
;; and removes the burden of quoting/unquoting, simulating
;; struct-style matching.

;; These will register all references to assembler opcodes for error
;; checking.

;; The transformer adds the appropriate quoting to the pattern and
;; unquoting to the template.


(define (syntax->warning stx)
  (let ((src  (syntax-source stx))
        (line (syntax-line stx))
        (col  (syntax-column stx)))
    (or
     (and src line col
          (format "~a:~a:~a" src line col)) ;; (add1 col)
     "<???>")))
  
(define (check-ins type ins)
  (syntax-case ins ()
    ((rator rand ...)
     (if (not (identifier? #'rator))
         (when #f ;; don't complain.  FIXME: add run-time checker
           (printf "~a: parametric ~a ~a\n"
                   (syntax->warning ins)
                   type
                   (syntax->datum ins)))
         (op-check-syntax ins)))))

;; Pass source location to runtime.
(define (srcloc stx)
  #`(make-pattern-srcloc
     #,(syntax-source stx)
     #,(syntax-line stx)
     #,(syntax-column stx)))

(define (asm-pattern-tx stx)
  (map
   (lambda (ins)
     (syntax-case ins (unquote)
       (,instruction           #'instruction)
       ((,tag arg ...)         #`(list tag arg ...))
       ((,tag arg ... . args)  #`(list-rest tag arg ... args))
       ((tag arg ...)          (begin
                                 (check-ins "pattern" ins)
                                 #`(list ;; (? (match-asm (asm: tag) 'tag #,(srcloc #'tag)))
                                         ;; 'tag
                                         (? (ns (op ?) tag))
                                         arg ...)))))
   (syntax->list stx)))

;; Parse the template as either the specific assembler syntax, or an
;; arbitrary scheme expression.
(define (asm-template-tx stx)
  (syntax-case stx (macro:)
    (((rator rand ...) ...)
     (begin
       (for ((_ins (syntax->list stx))) (check-ins "template" _ins))
       ;; #`(quasiquote ((op (unquote arg) ...) ...))
       ;; #`(list (list (asm: op) arg ...) ...)
       #`(list
          #,@(for/list ((ins (syntax->list stx)))
               (syntax-case ins (unquote)
                 (((unquote rator) rand ...) #`(list rator rand ...))
                 ((rator rand ...)           #`(op: rator rand ...))
                 )))
       ))
    (_  stx)))
    
  

(define (spec->name/match-clause stx)
  (syntax-case stx () 
    (((asm-pattern ... name) expr)
     (values 
      (name->identifier #'name)         ;; Convert strings to identifiers.
      (let ((pattern-lst
             (reverse                   ;; Reverse pattern at compile time.
              (asm-pattern-tx
               #'(asm-pattern ...))))
            (template
             #`(macro/append-reverse    ;; Reverse asm code result at runtime.
                #,(asm-template-tx #'expr)
                rest)))
        (if (null? pattern-lst)
            #`(rest #,template)
            #`((list-rest #,@pattern-lst rest) #,template)
            ))))))
               


;; Apply the above transformation for all patterns, and collect all
;; clauses for a single macro.

;; (<macro-name> <orig-patterns> <clauses>)

(define (specs->clause-dict specs)
  (map*
   ;; Transpose output of collect.
   (lambda (name . orig/clause)
     (list name
           (map first orig/clause)
           (map second orig/clause)))
   ;; Collect clauses per macro.
   (collect
    free-identifier=?
    (map
     (lambda (orig)
       (let-values
           (((name clause)
             (spec->name/match-clause orig)))
         (cons name                  ;; collect name
               (list orig clause)))) ;; payload
     ;; Straight from syntax object.
     (syntax->list specs)))))


;; Represent a list of match clauses.
(define (clauses->word name clauses)
  ;; (pretty-print (syntax->datum #`(#,name #,clauses)))
  #`(pattern-tx->macro
     '#,name
     #,(quasisyntax/loc
        name
;;        (with-handlers
;;            ((exn:misc:match?
;;              (lambda (e)
;;                (error 'patterns "Mismatch at: ~a" 'clauses))))
        (match-lambda
         #,@clauses
         (else (error 'patterns "Mismatch at: ~a" 'clauses))
         ))))




(define (transform-bindings specs)
  (map*
   (lambda (name origs clauses)
     #`(#,name
        (make-primitive-macro #,(clauses->word name clauses)
                              '#,origs)))
   (specs->clause-dict specs)))

;; Main transformer. This uses 'specs->clause-dict' and
;; 'clauses->word' to construct the outer scheme
;; expression. Redefinitions are allowed, and have the 'super' word
;; bound in the namespace.


(define (asm-transforms-tx namespace specs)
  #`(ns #,namespace
        #,(syntax-case (transform-bindings specs) ()
            (((name expr) ...)
             #'(define-values (name ...) (values expr ...))))))
  
;  #`(redefinitions!-ns
;     #,namespace
;     #,@(transform-bindings specs)))

;; Define multiple parameter words.

(define (with-asm-transforms-tx namespace specs)
  #`(lambda (thunk)
      (parameterize-words-ns! #,namespace
       #,(transform-bindings specs)
       (thunk))))



;; Anonymous transformer. The name in the pattern is ignored. By
;; convention _ is used.
(define (asm-lambda-tx specs)
  (let* ((clause-dict
          (specs->clause-dict specs)))
    (apply
     (lambda (origs clauses)
       #`(make-word
          #,(clauses->word #'<anonymous> clauses)
          '((pattern . #,origs))
          ))
     (list
      (apply append (map second clause-dict))
      (apply append (map third clause-dict))))))