;; syntax streams

;; For a concatenative language it makes sense to process syntax as a
;; stream instead of a tree.

(module stx-stream mzscheme

  (require "stream.ss"
           "tx-utils.ss")
  (require-for-syntax "tx-utils.ss")

  (provide (all-defined))


  ;; Convert read-syntax + port combo -> stream.
    
  (define (read-syntax/port->stream read-language-syntax file port)
    (let next ()
      (lazy
        (let ((thing (read-language-syntax file port)))
          (if (eof-object? thing)
              (begin
                (close-input-port port)
                @null)
              (@cons thing
                     (next)))))))


  
  (define (@unroll-stx stream number)
    (let-values
        (((head tail) (@pop stream number)))
      (values (datum->syntax-object
               #f head)
              tail)))
                  


  ;; Similar to @match, but using syntax-case. The unrolling binds
  ;; the tail of the stream separately to the specified identifier.

    
  (define-syntax @syntax-case
    (lambda (stx)
      (syntax-case stx ()
        ((_ stx-stream tail literals
            (pattern expr) . clauses)
         (let ((n (stx-length #'pattern)))
           #`(let-values
                 (((head tail)
                   (@unroll-stx stx-stream #,n)))
               (syntax-case head literals
                 (pattern expr)
                 . #,(if (stx-null? #'clauses)
                         #'()
                         #'((anything
                             (@syntax-case stx-stream tail literals
                                           . clauses)))))))))))
     
  ;; Convert syntax to syntax stream
  
  (define (@stx stx)
    (lazy
     (syntax-case stx ()
       ((a . b) (@cons #'a (@stx #'b)))
       (()      @null))))

  

  ;; A 'primitive parser' is a syntax stream processor that produces 2
  ;; output streams: the processed stream, and the remainder of the
  ;; unprocessed stream. This can be used by a driver (equiped with a
  ;; primitive parser dictionary) to provide either depth-first or
  ;; breath-first expansion.

  (define (@parsed stx-fragment stream+)
    (values (@stx stx-fragment) stream+))

  (define (@parse-just-copy stream)
    (@parsed
     #`(#,(@car stream))
     (@cdr stream)))
  
  (define (@apply-parsers name->parser code)
    (lazy
     (if (@null? code)
         code
         (let 
             ((@parser
               (name->parser (->datum (@car code)))))
           (let-values
               (((out code+)
                 ((or @parser
                      @parse-just-copy) code)))
             (@append out
                      (@apply-parsers name->parser
                                      code+)))))))

  ;; A syntax-rules style way for defining parser bodies.

  ;; (parser-rules ()
  ;;   ((_ a b) (a a b b)))
  
  (define-syntax parser-rules
    (syntax-rules ()
      ((_ literals
          (pattern template) ...)
       (lambda (stream)
         (@syntax-case stream s+ literals
           (pattern
            (@parsed
             #`template s+))
           ...)))))
           
  

  ;; This entry point consumes and produces lists of symbols instead
  ;; of syntax streams.
  (define (apply-parsers find code)
    (@unfold
     (@map ->datum
           (@apply-parsers
            find
            (@stx (->syntax #f code))))))
  

  
  ;; This macro creates a finite function: atom -> parser, which can
  ;; be used as an argument to 'apply-parsers'. For an example of the
  ;; use, have a look at 'interactive.ss'

  (define-syntax predicates->parsers
    (syntax-rules ()
      ((_ (pred/sym (pattern template) ...) ...)
       (lambda (atom)
         (cond
          (((as-predicate pred/sym) atom)
           (parser-rules
            () (pattern template) ...))
          ...
          (else #f))))))


  (define (as-predicate thing)
    (if (procedure? thing)
        thing
        (lambda (x) (eq? x thing))))


;;   ;; Create a collection of membership predicates. Useful in
;;   ;; combination with the previous macro. (see interactive.ss)
  
;;   (define-syntax with-member-predicates
;;     (syntax-rules ()
;;       ((_ ((effect . ops) ...) body)
;;        (let ((effect
;;               (lambda (op)
;;                 (case op (ops op) (else #f)))) ...)
;;          body))))





  ;; Chunking / collecting. Used as preprocessor for s-expression
  ;; based matching.

  ;; HACK: let it accept strings in addition to symbols.

  (define (as-symbol name)
    (if (symbol? name)
        name
        (string->symbol name)))
    

  (define (@stx-unflatten stream name)
    (let ((sym (as-symbol name)))
      (@unflatten stream
                (lambda (x)
                  (eq? (->datum x) sym)))))

  ;; Util
  (define-syntax @pop!
    (syntax-rules ()
      ((_ stream)
       (set! stream (@cdr stream)))))

  
  )