;;;; expand-full-test.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

(import test)

(test-begin "Expand Full")

;;;

(import
  (chicken syntax)
  expand-full)

(define-syntax stream-match-pattern
  (syntax-rules (_)
    ((stream-match-pattern STRM () (BINDING ...) BODY)
     (and (stream-null? STRM) (let (BINDING ...) BODY)))
    ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
     (and (stream-pair? STRM)
          (let ((STRM (stream-cdr STRM)))
            (stream-match-pattern STRM REST (BINDING ...) BODY))))
    ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
     (and (stream-pair? STRM)
          (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
            (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
    ((stream-match-pattern STRM _ (BINDING ...) BODY)
     (let (BINDING ...) BODY))
    ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     (let ((VAR STRM) BINDING ...) BODY))))

(define-syntax stream-match-test
  (syntax-rules ()
    ((stream-match-test STRM (PATTERN FENDER EXPR))
     (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
    ((stream-match-test STRM (PATTERN EXPR))
     (stream-match-pattern STRM PATTERN () (list EXPR)))))

(define-syntax stream-match
  (syntax-rules ()
    ((stream-match STRM-EXPR CLAUSE ...)
     (let ((strm STRM-EXPR))
       (cond ((not (stream? strm)) (error-invalid-stream 'stream-match strm))
             ((stream-match-test strm CLAUSE) => car) ...
             (else (error 'stream-match "pattern failure")))))))

;csc : invalid syntax in macro form: (y . ys)
;bug?

(define expd-test-data-1
  '(stream-match yy
    (() (stream (stream x)))
    ((y . ys)
      (stream-append
        (stream (stream-cons x yy))
        (stream-map (lambda (z) (stream-cons y z))
                    (stream-intersperse ys x))))))

(define expd-test-result-1
  '(##core#let
    ((strm yy))
    (##core#if
      (not (stream? strm))
      (##core#begin (error-invalid-stream (##core#quote stream-match) strm))
      (##core#let
        ((tmp (##core#if
                (stream-null? strm)
                (##core#let () (list (stream (stream x))))
                #f)))
        (##core#if
          tmp
          (car tmp)
          (##core#let
            ((tmp (##core#if
                    (stream-pair? strm)
                    (##core#let
                      ((temp (stream-car strm)) (strm (stream-cdr strm)))
                      (##core#let
                        ((ys strm) (y temp))
                        (list (stream-append
                                (stream (stream-cons x yy))
                                (stream-map
                                  (##core#lambda (z) (stream-cons y z))
                                  (stream-intersperse ys x))))))
                    #f)))
            (##core#if
              tmp
              (car tmp)
              (##core#begin
                (error (##core#quote stream-match) "pattern failure")))))))))

(cond-expand
  (csi
    (print) (print "stream s-expr expand")
    (ppexpand* expd-test-data-1)
    ;(test "stream s-expr expand" expd-test-result-1 (strip-gensym (expand* expd-test-data-1)))

    (print) (print "'(and a b) expand")
    (ppexpand* '(and a b))
    ;(test '(##core#if a b #f) (strip-gensym (expand* '(and a b))))
  )
  (else)
)

;;;

(test-end "Expand Full")

(test-exit)