subtemplate/private/ddd-forms.rkt

#lang racket/base
(provide begin
         let
         #%intdef-begin
         (rename-out [app #%app])
         ??
         ?if
         ?cond
         ?attr
         ?@
         ?@@
         splice-append
         splice-append*
         splicing-list?
         splicing-list
         splicing-list-l)

(require racket/list
         subtemplate/private/ddd
         stxparse-info/case
         stxparse-info/parse
         phc-toolkit/untyped
         subtemplate/private/copy-attribute
         (for-meta -2 subtemplate/private/syntax-case-as-syntax-parse)
         (for-meta -1 subtemplate/private/syntax-case-as-syntax-parse)
         (for-meta 0 subtemplate/private/syntax-case-as-syntax-parse)
         (for-meta 1 subtemplate/private/syntax-case-as-syntax-parse)
         (for-meta 2 subtemplate/private/syntax-case-as-syntax-parse)
         (for-meta 3 subtemplate/private/syntax-case-as-syntax-parse)
         (prefix-in - (only-in racket/base
                               begin let lambda define))
         (prefix-in - (only-in stxparse-info/case
                               define/with-syntax))
         (prefix-in - (only-in stxparse-info/parse
                               define/syntax-parse
                               syntax-parse))
         (for-syntax racket/base
                     racket/list
                     stxparse-info/parse
                     stxparse-info/parse/experimental/template
                     phc-toolkit/untyped)
         (for-meta 2 racket/base)
         (for-meta 2 phc-toolkit/untyped)
         (for-meta 2 stxparse-info/parse))

(begin-for-syntax
  (define (-nest* wrapper -v -ooo* [depth 0])
    (if (stx-null? -ooo*)
        -v
        (-nest* wrapper
                (wrapper -v)
                (stx-cdr -ooo*)
                (add1 depth))))
  
  (define-syntax nest*
    (syntax-parser
      [(self wrapper-stx v ooo*)
       (with-syntax ([s (datum->syntax #'self 'syntax)]
                     [qs (datum->syntax #'self 'quasisyntax)])
         #`(-nest* (λ (new-v)
                     (with-syntax ([#,(datum->syntax #'self '%) new-v])
                       (qs wrapper-stx)))
                   (s v)
                   (s ooo*)))]))

  (define-syntax ddd*
    (syntax-parser
      [(_ e ooo*)
       #'(with-syntax ([dotted (nest* (ddd %) e ooo*)])
           (nest* (append* %)
                  (list dotted)
                  ooo*))]))

  (define-syntax-class ooo
    (pattern {~and ooo {~literal …}}))

  (define-splicing-syntax-class ooo+
    #:attributes (ooo*)
    (pattern {~seq {~and ooo {~literal …}} …+}
             #:with ooo* #'(ooo …)))

  (define-syntax-class not-macro-id
    #:attributes ()
    (pattern id:id
             #:when (not (syntax-local-value #'id (λ () #f))))
    (pattern id:id
             #:when (syntax-pattern-variable?
                     (syntax-local-value #'id (λ () #f)))))

  (define-syntax-class not-macro-expr
    #:attributes ()
    (pattern :not-macro-id)
    (pattern (:not-macro-id . _)))
  
  (define-splicing-syntax-class stmt
    #:literals (define define/with-syntax -define/syntax-parse)
    (pattern {~seq (define name:id e:expr) :ooo+}
             #:with expanded
             #`(-define name
                        #,(nest* (ddd %) e ooo*)))
    (pattern {~seq (define/with-syntax pat e:expr) :ooo+}
             #:with expanded
             #`(-define/syntax-parse
                #,(nest* (… {~and {~or (% …) #f}}) ({~syntax-case pat}) ooo*)
                #,(nest* (ddd % #:allow-missing) (list e) ooo*)))
    (pattern {~seq (-define/syntax-parse pat e:expr) :ooo+}
             ;; Same as above, except that pat is not wrapped with ~syntax-case.
             #:with expanded
             #`(-define/syntax-parse
                #,(nest* (… {~and {~or (% …) #f}}) (pat) ooo*)
                #,(nest* (ddd % #:allow-missing) (list e) ooo*)))
    (pattern {~seq e :ooo+}
             ;#:with expanded #`(apply values #,(ddd* e ooo*))
             #:with expanded #`(splicing-list #,(ddd* e ooo*)))
    (pattern other
             #:with expanded #'other)))

(define-syntax/parse (begin stmt:stmt …)
  (template (-begin (?@ stmt.expanded) …)))

(define-syntax #%intdef-begin (make-rename-transformer #'begin))

(define-syntax/parse (let {~optional name:id} ([var . val] …) . body)
  (template (-let (?? name) ([var (begin . val)] …) (#%intdef-begin . body))))

(begin-for-syntax
  (define-splicing-syntax-class arg
    (pattern {~seq e:expr ooo*:ooo+}
             #:with expanded #`(splicing-list #,(ddd* e ooo*)))
    (pattern other
             ;#:with expanded #'(#%app list other)
             #:with expanded #'other))
  (define-syntax-class not-stx-pair
    (pattern () #:with v #''())
    (pattern {~and v {~not (_ . _)}})))
(define-syntax app
  (syntax-parser
    [{~and (_ fn arg:arg … . rest:not-stx-pair)
           {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a …
     ;#'(#%app apply fn (#%app append arg.expanded …))
     (syntax/top-loc this-syntax
       (#%plain-app apply fn (#%plain-app splice-append-nokw rest.v arg.expanded …)))]
    [(_ arg:arg … . rest:not-stx-pair) ;; shorthand for list creation
     ;#'(#%app apply list (#%app append arg.expanded …))
     #;(syntax/top-loc this-syntax
         (#%plain-app apply list
                      (#%plain-app splice-append-nokw rest.v arg.expanded …)))
     ;; (apply list v) is a no-op asside from error handling.
     (syntax/top-loc this-syntax
       (#%plain-app splice-append-nokw rest.v arg.expanded …))]))

(define (splice-append #:rest [rest '()] . l*)
  (splice-append* (if (null? rest) l* (append l* rest))))
(define (splice-append-nokw rest . l*)
  (splice-append* (if (null? rest) l* (append l* rest))))
(define (splice-append* l*)
  (cond
    [(pair? l*)
     (if (splicing-list? (car l*))
         (splice-append* (append (splicing-list-l (car l*))
                                 (cdr l*)))
         (cons (car l*) (splice-append* (cdr l*))))]
    [(splicing-list? l*)
     (splice-append* (splicing-list-l l*))]
    [else ;; should be null.
     l*]))