#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
         racket/list
         racket/function
         racket/format
         (for-syntax racket/base
                     syntax/parse
                     racket/syntax
                     phc-toolkit/untyped
                     racket/list
                     racket/pretty)
         "parameters.rkt"
         "try-attribute.rkt")

(provide define-eh-alternative-mixin
         ~seq-no-order
         ~no-order
         ~order-point
         order-point<
         order-point>
         try-order-point<
         try-order-point>
         ~lift-rest
         ~as-rest
         ~omitable-lifted-rest ;; Private
         (expander-out eh-mixin)) ;; Private

(define-expander-type eh-mixin)

(define-syntax define-eh-alternative-mixin
  (syntax-parser
    [(_ name
        (~maybe #:define-splicing-syntax-class splicing-name)
        (~maybe #:define-syntax-class class-name)
        ((~literal pattern) pat) ...)
     #`(begin
         (define-eh-mixin-expander name
           (λ (_)
             (syntax-local-syntax-parse-pattern-introduce
              (quote-syntax (~or pat ...)))))
         #,@(if (attribute splicing-name)
                #'((define-splicing-syntax-class splicing-name
                     (pattern {~seq-no-order {name}})))
                #'())
         #,@(if (attribute class-name)
                #'((define-syntax-class class-name
                     (pattern {~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)]))

(define-for-syntax parse-seq-order-sym-introducer (make-syntax-introducer))

(define-for-syntax (fix-disappeared-uses)
  ;; Fix for https://github.com/racket/racket/issues/1452
  (let ([dis (current-recorded-disappeared-uses)])
    #`{~do #,(with-disappeared-uses*
              (record-disappeared-uses dis)
              #'(void))}))

;; TODO: this does not work when there is a pattern expander which expands to
;; an ~or^eh
(define-for-syntax (catch-omitable-lifted-rest stx)
  (define caught '())
  (define (r stx)
    ;(displayln (list r stx))
    (cond
      [(syntax? stx) (datum->syntax stx (r (syntax-e stx)) stx stx)]
      [(and (pair? stx)
            (identifier? (car stx))
            (free-identifier=? (car stx) #'~or))
       (cons (car stx) (l (cdr stx)))]
      [(and (pair? stx)
            (identifier? (car stx))
            (free-identifier=? (car stx) #'~omitable-lifted-rest))
       (set! caught (cons stx caught))
       #'{~or}] ;; empty ~or with no eh alternatives
      [else stx]))
  (define (l stx)
    ;(displayln (list l stx))
    (cond
      [(syntax? stx) (datum->syntax stx (r (syntax-e stx)) stx stx)]
      [(list? stx) (map r stx)]
      [(pair? stx) (cons (r (car stx)) (l (cdr stx)))]
      [else stx]))
  (define cleaned (r stx))
  (values cleaned caught))

;; 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-for-syntax ((no-order-ish seq?) stx)
  (syntax-case stx ()
    [(self pat ...)
     (with-disappeared-uses*
      (define counter 0)
      (define (increment-counter!)
        (begin0 counter
                (set! counter (add1 counter))))
      ;; first, pre and post-acc gather a-patterns which will be added after
      ;; the (~seq (~or ) ...), before and after the ~! cut respectively
      (define first-acc '())
      (define (add-to-first! v) (set! first-acc (cons v first-acc)))
      (define pre-acc '())
      (define (add-to-pre! v) (set! pre-acc (cons v pre-acc)))
      (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)))
      (define lifted-rest '())
      (define (add-to-lift-rest! present-clause expanded-pat)
        (define succeeded (get-new-clause!))
        (set! lifted-rest (cons (list present-clause
                                      expanded-pat
                                      succeeded)
                                lifted-rest)))
      ;; expand EH alternatives:
      (parameterize ([eh-first-accumulate add-to-first!]
                     [eh-pre-accumulate add-to-pre!]
                     [eh-post-group add-to-post-groups!]
                     [eh-post-accumulate add-to-post!]
                     [clause-counter increment-counter!]
                     [lift-rest add-to-lift-rest!])
        (define alts
          (expand-all-eh-mixin-expanders #'(~or pat ...)))
        ;; TODO: we can probably close the "parameterize" here.



        
        ;; NOTE: this works only because eh-mixin-expanders are NOT pattern
        ;; expanders. If these are merged later on, then this needs to be
        ;; adjusted
        (define-values (cleaned-alts caught-omitable-lifted-rest)
          (catch-omitable-lifted-rest alts))
        (define post-group-bindings
          (for/list ([group (group-by car
                                      (reverse 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))]))
        (set! lifted-rest (reverse lifted-rest))
        (define/with-syntax whole-clause (get-new-clause!))
        (define/with-syntax rest-clause (get-new-clause!))
        (define/with-syntax parse-seq-order-sym-id
          (datum->syntax (parse-seq-order-sym-introducer
                          (syntax-local-introduce #'here))
                         'parse-seq-order-sym))
        (define/with-syntax whole-clause-pat
          (if seq?
              (begin
                (when (not (null? lifted-rest))
                  (raise-syntax-error
                   '~seq-no-order
                   (string-append "rest clause must be used within ~no-order,"
                                  " but was used within ~seq-no-order")
                   stx))
                #'{~seq whole-clause (… …) {~bind [(rest-clause 1) (list)]}})
              #'(whole-clause (… …) . {~and rest-clause {~not (_ . _)}})))
        (define rest-handlers
          (if (null? lifted-rest)
              #'()
              (with-syntax ([[(present expanded-pat succeeded) …] lifted-rest])
                #'({~parse
                    {~or (_ {~parse #t
                                    (ormap identity
                                           (flatten (attribute present)))}
                            {~parse expanded-pat
                                    #'rest-clause}
                            {~bind [succeeded #t]})
                         …
                         (_ {~fail (~a "expected one of the rest patterns"
                                       " to match")})}
                    #'(dummy)}))))
        (define check-no-dup-rest-handlers
          (if (null? lifted-rest)
              #'()
              (with-syntax ([([present expanded-pat succeeded] …) lifted-rest])
                #'({~fail #:when (or (and (not (attribute succeeded))
                                          (ormap identity
                                                 (flatten (attribute present)))
                                          (syntax-parse #'rest-clause
                                            [expanded-pat #t]
                                            [_ #f]))
                                     …)
                          (~a "more than one of the lifted rest patterns"
                              " matched")}))))

        ((λ (x) #;(pretty-write (syntax->datum #`(syntax-parser [#,x 'ok]))) x)
         #`(~delimit-cut
            (~and #,(fix-disappeared-uses)
                  whole-clause-pat
                  {~do (define parse-seq-order-sym-id
                         (gensym 'parse-seq-order))}
                  {~parse ({~seq #,cleaned-alts (… …)})
                          #`#,(for/list
                                  ([xi (in-syntax #'(whole-clause (… …)))]
                                   [i (in-naturals)])
                                ;; Add a syntax property before parsing,
                                ;; to track the position of matched elements
                                ;; using ~order-point
                                (syntax-property xi
                                                 parse-seq-order-sym-id
                                                 i))}
                  #,@(reverse first-acc)
                  #,@(reverse pre-acc)
                  #,@caught-omitable-lifted-rest
                  #,@rest-handlers
                  ~!
                  #,@check-no-dup-rest-handlers
                  (~bind #,@post-group-bindings)
                  #,@(reverse post-acc))))))]))

(define-syntax ~seq-no-order (pattern-expander (no-order-ish #t)))
(define-syntax ~no-order (pattern-expander (no-order-ish #f)))

(define-eh-mixin-expander ~order-point
  (λ (stx)
    (define/with-syntax clause-point (get-new-clause!))
    (define/with-syntax parse-seq-order-sym-id
      (datum->syntax (parse-seq-order-sym-introducer
                      (syntax-local-introduce #'here))
                     'parse-seq-order-sym))
    (syntax-case stx ()
      [(_ point-name pat …)
       #'{~and {~seq pat …}
               {~either {~and {~seq clause-point _ (… …)}
                              {~bind
                               [point-name
                                (syntax-property #'clause-point
                                                 parse-seq-order-sym-id)]}}
                        {~and {~seq}
                              {~bind [point-name #f]}}}}])))

(define-syntax-rule (order-point< a b)
  (and (attribute a) (attribute b)
       (< (attribute a) (attribute b))))

(define-syntax-rule (order-point> a b)
  (and (attribute a) (attribute b)
       (> (attribute a) (attribute b))))

(define-syntax-rule (try-order-point< a b)
  (if-attribute a (if-attribute b (order-point< a b) #f) #f))

(define-syntax-rule (try-order-point> a b)
  (if-attribute a (if-attribute b (order-point> a b) #f) #f))

(define-syntax ~omitable-lifted-rest
  (pattern-expander
   (λ (stx)
     (syntax-case stx ()
       [(_ expanded-pats clause-present)
        #'{~and
           ;; TODO: copy the disappeared uses instead of this hack
           {~do 'expanded-pats}
           {~bind [clause-present #t]}}]))))

(define-eh-mixin-expander ~as-rest
  (λ (stx)
    (syntax-case stx ()
      [(_ pat ...)
       (let ()
         (define/with-syntax clause-present (get-new-clause!))
         (define/with-syntax clause-seq (get-new-clause!))
         (define/with-syntax (expanded-pat ...)
           ;; let the ~post, ~global etc. within pat … be recognized
           (stx-map expand-all-eh-mixin-expanders #'(pat ...)))
         (lift-rest! '~lift-rest
                     #'clause-present
                     #'({~parse (expanded-pat ...)
                                #'(clause-seq (... ...))}))
         #'{~seq clause-seq (... ...)
                 {~bind [clause-present #t]}})])))

(define-eh-mixin-expander ~lift-rest
  (λ (stx)
    (syntax-case stx ()
      [(_ pat)
       (let ()
         (define/with-syntax clause-present (get-new-clause!))
         (define/with-syntax expanded-pat
           ;; let the ~post, ~global etc. within pat … be recognized
           (expand-all-eh-mixin-expanders #'pat))
         (lift-rest! '~lift-rest #'clause-present #'expanded-pat)
         #'(~omitable-lifted-rest expanded-pat clause-present))])))