#lang racket/base

;; TODO: it should be possible to specify a partial ordering and/or join the
;; constraints for multiple occurrences of the same ~no-order clause. The goal
;; is to be able to write a pattern for:
;; (some-macro opts … name opts … field … opts …)
;; where opts is a ~no-order, with some constraints like ~once, ~optional etc.
;; I'd like to write something like:
;; (some-macro (~no-order #:kw1
;;                        (~seq #:kw2 opt2)
;;                        name:id
;;                        (~and fields
;;                              (~seq field:id …)
;;                              (~global-before name fields))))
;; However, the current implementation uses "(~or no-order-clauses) …" which
;; does not permit a clause to see previously matched clauses.
;; Maybe save this for the unified parser and generator library (see on github
;; the repo jsmaniac/phc-toolkit, more specifically the file
;; scribblings/template.scrbl within).

(require syntax/parse
         ;syntax/parse/experimental/eh
         generic-syntax-expanders
         phc-toolkit/untyped
         (for-syntax racket/base
                     syntax/parse
                     racket/syntax
                     phc-toolkit/untyped
                     racket/list
                     racket/pretty)
         "parameters.rkt")

(provide define-eh-alternative-mixin
         ~seq-no-order
         ~no-order
         (expander-out eh-mixin))

(define-expander-type eh-mixin)

(define-syntax define-eh-alternative-mixin
  (syntax-parser
    [(_ name (~maybe #:define-splicing-syntax-class splicing-name)
        ((~literal pattern) pat) ...)
     #`(begin
         (define-eh-mixin-expander name
           (λ (_)
             (quote-syntax (~or pat ...))))
         #,@(if (attribute splicing-name)
                #'((define-splicing-syntax-class splicing-name
                     (pattern {~seq-no-order {name}})))
                #'()))]))

(define-for-syntax (inline-or stx)
  (syntax-case stx ()
    [(o . rest)
     (and (identifier? #'o) (free-identifier=? #'o #'~or))
     (apply append (stx-map inline-or #'rest))]
    [x (list #'x)]))

;; TODO: ~seq-no-order should also be a eh-mixin-expander, so that when there
;; are nested ~seq-no-order, the ~post-fail is caught by the nearest
;; ~seq-no-order.
(define-syntax ~seq-no-order
  (pattern-expander
   (λ (stx)
     (syntax-case stx ()
       [(self pat ...)
        (with-disappeared-uses
         (let ()
           (define counter 0)
           (define (increment-counter)
             (begin0 counter
                     (set! counter (add1 counter))))
           ;; post-acc gathers some a-patterns which will be added after the
           ;; (~seq (~or ) ...)
           (define post-acc '())
           (define (add-to-post! v) (set! post-acc (cons v post-acc)))
           ;; post-groups-acc gathers some attributes that have to be grouped
           (define post-groups-acc '())
           (define (add-to-post-groups! . v)
             (set! post-groups-acc (cons v post-groups-acc)))
           ;; expand EH alternatives:
           (define alts
             (parameterize ([eh-post-accumulate add-to-post!]
                            [eh-post-group add-to-post-groups!]
                            [clause-counter increment-counter])
               ;(inline-or
               (expand-all-eh-mixin-expanders #'(~or pat ...))))
           (define post-group-bindings
             (for/list ([group (group-by car
                                         post-groups-acc
                                         free-identifier=?)])
               ;; each item in `group` is a four-element list:
               ;; (list result-id aggregate-function attribute)
               (define/with-syntax name (first (car group))
                 #;(syntax-local-introduce
                    (datum->syntax #'here
                                   (first (car group)))))
               (define/with-syntax f (second (car group)))
               #`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
                                   group))]))
           #`(~delimit-cut
              (~and (~seq #,alts (... ...)) ;;(~or . #,alts)
                    ~!
                    (~bind #,@post-group-bindings)
                    #,@post-acc))))]))))

(define-syntax ~no-order
  (pattern-expander
   (λ/syntax-case (_ . rest) ()
     #'({~seq-no-order . rest}))))