#lang racket/base
(require racket/list
         racket/format
         syntax/stx
         racket/struct
         syntax/srcloc
         "minimatch.rkt"
         syntax/parse/private/residual
         "kws.rkt")
(provide call-current-failure-handler
         current-failure-handler
         invert-failure
         maximal-failures
         invert-ps
         ps->stx+index)

#|
TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
  simplify to (expect:thing _ D _ #f)
  thus, "expected D" rather than "expected D or D for R" (?)
|#

#|
Note: there is a cyclic dependence between residual.rkt and this module,
broken by a lazy-require of this module into residual.rkt
|#

(define (call-current-failure-handler ctx fs)
  (call-with-values (lambda () ((current-failure-handler) ctx fs))
    (lambda vals
      (error 'current-failure-handler
             "current-failure-handler: did not escape, produced ~e"
             (case (length vals)
               ((1) (car vals))
               (else (cons 'values vals)))))))

(define (default-failure-handler ctx fs)
  (handle-failureset ctx fs))

(define current-failure-handler
  (make-parameter default-failure-handler))


;; ============================================================
;; Processing failure sets

#|
We use progress to select the maximal failures and determine the syntax
they're complaining about. After that, we no longer care about progress.

Old versions of syntax-parse (through 6.4) grouped failures into
progress-equivalence-classes and generated reports by class, but only showed
one report. New syntax-parse just mixes all maximal failures together and
deals with the fact that they might not be talking about the same terms.
|#

;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
(define (handle-failureset ctx fs)
  (define inverted-fs (map invert-failure (reverse (flatten fs))))
  (define maximal-classes (maximal-failures inverted-fs))
  (define ess (map failure-expectstack (append* maximal-classes)))
  (define report (report/sync-shared ess))
  ;; Hack: alternative to new (primitive) phase-crossing exn type is to store
  ;; extra information in exn continuation marks. Currently for debugging only.
  (with-continuation-mark 'syntax-parse-error
    (hasheq 'raw-failures fs
            'maximal maximal-classes)
    (error/report ctx report)))

;; An RFailure is (failure IPS RExpectList)

;; invert-failure : Failure -> RFailure
(define (invert-failure f)
  (match f
    [(failure ps es)
     (failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))]))

;; A Report is (report String (Listof String) Syntax/#f Syntax/#f)
(define-struct report (message context stx within-stx) #:prefab)

;; Sometimes the point where an error occurred does not correspond to
;; a syntax object within the original term being matched. We use one
;; or two syntax objects to identify where an error occurred:
;; - the "at" term is the specific point of error, coerced to a syntax
;;   object if it isn't already
;; - the "within" term is the closest enclosing original syntax object,
;;   dropped (#f) if same as "at" term

;; Examples (AT is pre-coercion):
;; TERM        PATTERN     =>  AT      WITHIN
;; #'(1)       (a:id)          #'1     --            ;; the happy case
;; #'(1)       (a b)           ()      #'(1)         ;; tail of syntax list, too short
;; #'(1 . ())  (a b)           #'()    --            ;; tail is already syntax
;; #'#(1)      #(a b)          ()      #'#(1)        ;; "tail" of syntax vector
;; #'#s(X 1)   #s(X a b)       ()      #'#s(X 1)     ;; "tail" of syntax prefab
;; #'(1 2)     (a)             (#'2)   #'(1 2)       ;; tail of syntax list, too long


;; ============================================================
;; Progress

;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure))
(define (maximal-failures fs)
  (maximal/progress
   (for/list ([f (in-list fs)])
     (cons (failure-progress f) f))))

#|
Progress ordering
-----------------

Nearly a lexicographic generalization of partial order on frames.
  (( CAR < CDR ) || stx ) < POST )
  - stx incomparable except with self

But ORD prefixes are sorted out (and discarded) before comparison with 
rest of progress. Like post, ord comparable only w/in same group:
  - (ord g n1) < (ord g n2) if n1 < n2
  - (ord g1 n1) || (ord g2 n2) when g1 != g2


Progress equality
-----------------

If ps1 = ps2 then both must "blame" the same term,
ie (ps->stx+index ps1) = (ps->stx+index ps2).
|#

;; An Inverted PS (IPS) is a PS inverted for easy comparison.
;; An IPS may not contain any 'opaque frames.

;; invert-ps : PS -> IPS
;; Reverse and truncate at earliest 'opaque frame.
(define (invert-ps ps)
  (reverse (ps-truncate-opaque ps)))

;; ps-truncate-opaque : PS -> PS
;; Returns maximal tail with no 'opaque frame.
(define (ps-truncate-opaque ps)
  (let loop ([ps ps] [acc ps])
    ;; acc is the biggest tail that has not been seen to contain 'opaque
    (cond [(null? ps) acc]
          [(eq? (car ps) 'opaque)
           (loop (cdr ps) (cdr ps))]
          [else (loop (cdr ps) acc)])))

;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A))
;; Eliminates As with non-maximal progress, then groups As into
;; equivalence classes according to progress.
(define (maximal/progress items)
  (cond [(null? items)
         null]
        [(null? (cdr items))
         (list (list (cdr (car items))))]
        [else
         (let loop ([items items] [non-ORD-items null])
           (define-values (ORD non-ORD)
             (partition (lambda (item) (ord? (item-first-prf item))) items))
           (cond [(pair? ORD)
                  (loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))]
                 [else
                  (maximal/prf1 (append non-ORD non-ORD-items))]))]))

;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A))
(define (maximal/prf1 items)
  (define-values (POST rest1)
    (partition (lambda (item) (eq? 'post (item-first-prf item))) items))
  (cond [(pair? POST)
         (maximal/progress (map item-pop-prf POST))]
        [else
         (define-values (STX rest2)
           (partition (lambda (item) (syntax? (item-first-prf item))) rest1))
         (define-values (CDR rest3)
           (partition (lambda (item) (exact-integer? (item-first-prf item))) rest2))
         (define-values (CAR rest4)
           (partition (lambda (item) (eq? 'car (item-first-prf item))) rest3))
         (define-values (NULL rest5)
           (partition (lambda (item) (eq? '#f (item-first-prf item))) rest4))
         (unless (null? rest5)
           (error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5))
         (cond [(pair? CDR)
                (define leastCDR (apply min (map item-first-prf CDR)))
                (append
                 (maximal/stx STX)
                 (maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))]
               [(pair? CAR)
                (append
                 (maximal/stx STX)
                 (maximal/progress (map item-pop-prf CAR)))]
               [(pair? STX)
                (maximal/stx STX)]
               [(pair? NULL)
                (list (map cdr NULL))]
               [else null])]))

;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A))
;; PRE: each item has ORD first frame
;; Keep only maximal by first frame and pop first frame from each item.
(define (maximal-prf1/ord items)
  ;; groups : (NEListof (NEListof (cons A IPS)))
  (define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items))
  (append*
   (for/list ([group (in-list groups)])
     (define group* (filter-max group (lambda (item) (ord-index (item-first-prf item)))))
     (map item-pop-prf group*))))

;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A))
;; PRE: Each IPS starts with a stx frame.
(define (maximal/stx items)
  ;; groups : (Listof (Listof (cons IPS A)))
  (define groups (group-by item-first-prf items))
  (append*
   (for/list ([group (in-list groups)])
     (maximal/progress (map item-pop-prf group)))))

;; filter-max : (Listof X) (X -> Nat) -> (Listof X)
(define (filter-max xs x->nat)
  (let loop ([xs xs] [nmax -inf.0] [r-keep null])
    (cond [(null? xs)
           (reverse r-keep)]
          [else
           (define n0 (x->nat (car xs)))
           (cond [(> n0 nmax)
                  (loop (cdr xs) n0 (list (car xs)))]
                 [(= n0 nmax)
                  (loop (cdr xs) nmax (cons (car xs) r-keep))]
                 [else
                  (loop (cdr xs) nmax r-keep)])])))

;; item-first-prf : (cons IPS A) -> prframe/#f
(define (item-first-prf item)
  (define ips (car item))
  (and (pair? ips) (car ips)))

;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A))
(define (item-split-ord item)
  (define ips (car item))
  (define a (cdr item))
  (define-values (rest-ips r-ord)
    (let loop ([ips ips] [r-ord null])
      (cond [(and (pair? ips) (ord? (car ips)))
             (loop (cdr ips) (cons (car ips) r-ord))]
            [else (values ips r-ord)])))
  (list* (reverse r-ord) rest-ips a))

;; item-pop-prf : (cons IPS A) -> (cons IPS A)
(define (item-pop-prf item)
  (let ([ips (car item)]
        [a (cdr item)])
    (cons (cdr ips) a)))

;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A)
;; Assumes first frame is nat > ncdrs.
(define (item-pop-prf-ncdrs item ncdrs)
  (let ([ips (car item)]
        [a (cdr item)])
    (cond [(= (car ips) ncdrs) (cons (cdr ips) a)]
          [else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)])))

;; StxIdx = (cons Syntax Nat), the "within" term and offset (#cdrs) of "at" subterm

;; ps->stx+index : Progress -> StxIdx
;; Gets the innermost stx that should have a real srcloc, and the offset
;; (number of cdrs) within that where the progress ends.
(define (ps->stx+index ps)
  (define (interp ps top?)
    ;; if top?: first frame is 'car, must return Syntax, don't unwrap vector/struct
    (match ps
      [(cons (? syntax? stx) _) stx]
      [(cons 'car parent)
       (let* ([x (interp parent #f)]
              [d (if (syntax? x) (syntax-e x) x)])
         (cond [(pair? d) (car d)]
               [(vector? d)
                (if top? x (vector->list d))]
               [(box? d) (unbox d)]
               [(prefab-struct-key d)
                (if top? x (struct->list d))]
               [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
      [(cons (? exact-positive-integer? n) parent)
       (for/fold ([stx (interp parent #f)]) ([i (in-range n)])
         (stx-cdr stx))]
      [(cons (? ord?) parent)
       (interp parent top?)]
      [(cons 'post parent)
       (interp parent top?)]))
  (let loop ([ps (ps-truncate-opaque ps)])
    (match ps
      [(cons (? syntax? stx) _)
       (cons stx 0)]
      [(cons 'car _)
       (cons (interp ps #t) 0)]
      [(cons (? exact-positive-integer? n) parent)
       (match (loop parent)
         [(cons stx m) (cons stx (+ m n))])]
      [(cons (? ord?) parent)
       (loop parent)]
      [(cons 'post parent)
       (loop parent)])))

;; stx+index->at+within : StxIdx -> (values Syntax Syntax/#f)
(define (stx+index->at+within stx+index)
  (define within-stx (car stx+index))
  (define index (cdr stx+index))
  (cond [(zero? index)
         (values within-stx #f)]
        [else
         (define d (syntax-e within-stx))
         (define stx*
           (cond [(vector? d) (vector->list d)]
                 [(prefab-struct-key d) (struct->list d)]
                 [else within-stx]))
         (define at-stx*
           (for/fold ([x stx*]) ([_i (in-range index)]) (stx-cdr x)))
         (values (datum->syntax within-stx at-stx* within-stx)
                 within-stx)]))

;; ============================================================
;; Expectation simplification

;; normalize-expectstack : ExpectStack StxIdx -> ExpectList
;; Converts to list, converts expect:thing term rep, and truncates
;; expectstack after opaque (ie, transparent=#f) frames.
(define (normalize-expectstack es stx+index [truncate-opaque? #t])
  (reverse (invert-expectstack es stx+index truncate-opaque?)))

;; invert-expectstack : ExpectStack StxIdx -> RExpectList
;; Converts to reversed list, converts expect:thing term rep,
;; and truncates expectstack after opaque (ie, transparent=#f) frames.
(define (invert-expectstack es stx+index [truncate-opaque? #t])
  (let loop ([es es] [acc null])
    (match es
      ['#f acc]
      ['#t acc]
      [(expect:thing ps desc tr? role rest-es)
       (let* (;; discard frames so far if opaque
              [acc (if (and truncate-opaque? (not tr?)) null acc)]
              ;; discard this frame if desc is #f
              [acc (if desc (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc) acc)])
         (loop rest-es acc))]
      [(expect:message message rest-es)
       (loop rest-es (cons (expect:message message stx+index) acc))]
      [(expect:atom atom rest-es)
       (loop rest-es (cons (expect:atom atom stx+index) acc))]
      [(expect:literal literal rest-es)
       (loop rest-es (cons (expect:literal literal stx+index) acc))]
      [(expect:proper-pair first-desc rest-es)
       (loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))])))

;; expect->stxidx : Expect -> StxIdx
(define (expect->stxidx e)
  (cond [(expect:thing? e) (expect:thing-next e)]
        [(expect:message? e) (expect:message-next e)]
        [(expect:atom? e) (expect:atom-next e)]
        [(expect:literal? e) (expect:literal-next e)]
        [(expect:proper-pair? e) (expect:proper-pair-next e)]
        [(expect:disj? e) (expect:disj-next e)]))

#| Simplification

A list of ExpectLists represents a tree, with shared tails meaning shared
branches of the tree. We need a "reasonable" way to simplify it to a list to
show to the user. Here we develop "reasonable" by example. (It would be nice,
of course, to also have some way of exploring the full failure trees.)

Notation: [A B X] means an ExpectList with class/description A at root and X
at leaf. If the term sequences differ, write [t1:A ...] etc.

Options:
  (o) = "old behavior (through 6.4)"
  (f) = "first divergence"
  (s) = "sync on shared"

Case 1: [A B X], [A B Y]

  This is nearly the ideal situation: report as

    expected X or Y, while parsing B, while parsing A

Case 2: [A X], [A]

  For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()],
  but we don't want to see "expected ()".

  So simplify to [A]---that is, drop X.

But there are other cases that are more problematic.

Case 3:  [t1:A t2:B t3:X], [t1:A t2:C t3:Y]

  Could report as:
  (o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors)
  (f) expected B or C for t2, while parsing t1 as A
  (x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A

  (o) is not good
  (b) loses the most specific error information
  (x) implies spurious contexts (eg, X while parsing C)

  I like (b) best for this situation, but ...

Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y]

  Could report as:
  (f') expected B or C, while parsing t1 as A
  (s) expected X or Y for t4, while ..., while parsing t1 as A
  (f) expected A for t1

  (f') is problematic, since terms are different!
  (s) okay, but nothing good to put in that ... space
  (f) loses a lot of information

Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y]

  Only feasible choice (no other sync points):
  (f,s) expected A for t1

Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y]

  Could report as:
  (s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A
  (s) expected X or Y for t3, while ..., while parsing t1 as A

  (s') again implies spurious contexts, bad
  (s) okay

Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _]

  Same frames show up in different orders. (Can this really happen? Probably,
  with very weird uses of ~parse.)

--

This suggests the following new algorithm based on (s):
- Step 1: emit an intermediate "unified" expectstack (extended with "..." markers)
  - make a list (in order) of frames shared by all expectstacks
  - emit those frames with "..." markers if (sometimes) unshared stuff between
  - continue processing with the tails after the last shared frame:
  - find the last term shared by all expectstacks (if any)
  - find the last frame for that term for each expectstack
  - combine in expect:disj and emit
- Step 2:
  - remove trailing and collapse adjacent "..." markers

|#

;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList)
;;        -> Report
(define (report* ess handle-divergence)
  (define es ;; ExpectList
    (let loop ([ess ess] [acc null])
      (cond [(ormap null? ess) acc]
            [else
             (define groups (group-by car ess))
             (cond [(singleton? groups)
                    (define group (car groups))
                    (define frame (car (car group)))
                    (loop (map cdr group) (cons frame acc))]
                   [else ;; found point of divergence
                    (append (handle-divergence groups) acc)])])))
  (define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0)))
  (report/expectstack (clean-up es) stx+index))

;; clean-up : ExpectList -> ExpectList
;; Remove leading and collapse adjacent '... markers
(define (clean-up es)
  (if (and (pair? es) (eq? (car es) '...))
      (clean-up (cdr es))
      (let loop ([es es])
        (cond [(null? es) null]
              [(eq? (car es) '...)
               (cons '... (clean-up es))]
              [else (cons (car es) (loop (cdr es)))]))))

;; --

;; report/first-divergence : (NEListof RExpectList) -> Report
;; Generate a single report, using frames from root to first divergence.
(define (report/first-divergence ess)
  (report* ess handle-divergence/first))

;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList
(define (handle-divergence/first ess-groups)
  (define representative-ess (map car ess-groups))
  (define first-frames (map car representative-ess))
  ;; Do all of the first frames talk about the same term?
  (cond [(all-equal? (map expect->stxidx first-frames))
         (list (expect:disj first-frames #f))]
        [else null]))

;; --

;; report/sync-shared : (NEListof RExpectList) -> Report
;; Generate a single report, syncing on shared frames (and later, terms).
(define (report/sync-shared ess)
  (report* ess handle-divergence/sync-shared))

;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList
(define (handle-divergence/sync-shared ess-groups)
  (define ess (append* ess-groups)) ;; (NEListof RExpectList)
  (define shared-frames (get-shared ess values))
  ;; rsegs : (NEListof (Rev2n+1-Listof RExpectList))
  (define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames)))
  (define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames
  (define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList))
  (append (hd/sync-shared/final final-seg)
          (hd/sync-shared/ctx ctx-rsegs)))

;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList
;; PRE: ess has no shared frames, but may have shared terms.
(define (hd/sync-shared/final ess0)
  (define ess (remove-extensions ess0))
  (define shared-terms (get-shared ess expect->stxidx))
  (cond [(null? shared-terms) null]
        [else
         ;; split at the last shared term
         (define rsegs ;; (NEListof (3-Listof RExpectList))
           (for/list ([es (in-list ess)])
             (rsplit es expect->stxidx (list (last shared-terms)))))
         ;; only care about the got segment and pre, not post
         (define last-term-ess ;; (NEListof RExpectList)
           (map cadr rsegs))
         (define pre-term-ess ;; (NEListof RExpectList)
           (map caddr rsegs))
         ;; last is most specific
         (append
          (list (expect:disj (remove-duplicates (reverse (map last last-term-ess)))
                             (last shared-terms)))
          (if (ormap pair? pre-term-ess) '(...) '()))]))

;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList
;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most.
;; We want leaf-most-first, so just process naturally.
(define (hd/sync-shared/ctx rsegs)
  (let loop ([rsegs rsegs])
    (cond [(null? rsegs) null]
          [(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")]
          [else (append
                 ;; shared frame: possible for duplicate ctx frames, but unlikely
                 (let ([ess (car rsegs)]) (list (car (car ess))))
                 ;; inter frames:
                 (let ([ess (cadr rsegs)]) (if (ormap  pair? ess) '(...) '()))
                 ;; recur
                 (loop (cddr rsegs)))])))

;; transpose : (Listof (Listof X)) -> (Listof (Listof X))
(define (transpose xss)
  (cond [(ormap null? xss) null]
        [else (cons (map car xss) (transpose (map cdr xss)))]))

;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y)
;; Return a list of Ys s.t. occur in order in (map of) each xs in xss.
(define (get-shared xss get-y)
  (cond [(null? xss) null]
        [else
         (define yhs ;; (Listof (Hash Y => Nat))
           (for/list ([xs (in-list xss)])
             (for/hash ([x (in-list xs)] [i (in-naturals 1)])
               (values (get-y x) i))))
         (remove-duplicates
          (let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)])
            ;; last is list of indexes of last accepted y; only accept next if occurs
            ;; after last in every sequence (see Case 7 above)
            (cond [(null? xs) null]
                  [else
                   (define y (get-y (car xs)))
                   (define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1)))
                   (cond [(andmap > curr last)
                          (cons y (loop (cdr xs) curr))]
                         [else (loop (cdr xs) last)])])))]))

;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X))
;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1].
;; Thus the result has 2N+1 elements. The sublists are in original order.
(define (rsplit xs get-y ys)
  (define (loop xs ys segsacc)
    (cond [(null? ys) (cons xs segsacc)]
          [else (pre-loop xs ys segsacc null)]))
  (define (pre-loop xs ys segsacc preacc)
    (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
           (got-loop (cdr xs) ys segsacc preacc (list (car xs)))]
          [else
           (pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))]))
  (define (got-loop xs ys segsacc preacc gotacc)
    (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
           (got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))]
          [else
           (loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))]))
  (loop xs ys null))

;; singleton? : list -> boolean
(define (singleton? x) (and (pair? x) (null? (cdr x))))

;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X))
;; Remove any element that is an extension of another.
(define (remove-extensions xss)
  (cond [(null? xss) null]
        [else
         (let loop ([xss xss])
           (cond [(singleton? xss) xss]
                 [(ormap null? xss) (list null)]
                 [else
                  (define groups (group-by car xss))
                  (append*
                   (for/list ([group (in-list groups)])
                     (define group* (loop (map cdr group)))
                     (map (lambda (x) (cons (caar group) x)) group*)))]))]))

;; all-equal? : (Listof Any) -> Boolean
(define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs))))


;; ============================================================
;; Reporting

;; report/expectstack : ExpectList StxIdx -> Report
(define (report/expectstack es stx+index)
  (define frame-expect (and (pair? es) (car es)))
  (define context-frames (if (pair? es) (cdr es) null))
  (define context (append* (map context-prose-for-expect context-frames)))
  (cond [(not frame-expect)
         (report "bad syntax" context #f #f)]
        [else
         (define-values (frame-stx within-stx) (stx+index->at+within stx+index))
         (cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f])
                     (stx-pair? frame-stx))
                (report "unexpected term" context (stx-car frame-stx) #f)]
               [(expect:disj? frame-expect)
                (report (prose-for-expects (expect:disj-expects frame-expect))
                        context frame-stx within-stx)]
               [else
                (report (prose-for-expects (list frame-expect))
                        context frame-stx within-stx)])]))

;; prose-for-expects : (listof Expect) -> string
(define (prose-for-expects expects)
  (define msgs (filter expect:message? expects))
  (define things (filter expect:thing? expects))
  (define literal (filter expect:literal? expects))
  (define atom/symbol
    (filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects))
  (define atom/nonsym
    (filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects))
  (define proper-pairs (filter expect:proper-pair? expects))
  (join-sep
   (append (map prose-for-expect (append msgs things))
           (prose-for-expects/literals literal "identifiers")
           (prose-for-expects/literals atom/symbol "literal symbols")
           (prose-for-expects/literals atom/nonsym "literals")
           (prose-for-expects/pairs proper-pairs))
   ";" "or"))

(define (prose-for-expects/literals expects whats)
  (cond [(null? expects) null]
        [(singleton? expects) (map prose-for-expect expects)]
        [else
         (define (prose e)
           (match e
             [(expect:atom (? symbol? atom) _)
              (format "`~s'" atom)]
             [(expect:atom atom _)
              (format "~s" atom)]
             [(expect:literal literal _)
              (format "`~s'" (syntax-e literal))]))
         (list (string-append "expected one of these " whats ": "
                              (join-sep (map prose expects) "," "or")))]))

(define (prose-for-expects/pairs expects)
  (if (pair? expects) (list (prose-for-proper-pair-expects expects)) null))

;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
  (match e
    [(expect:thing _ description transparent? role _)
     (if role
         (format "expected ~a for ~a" description role)
         (format "expected ~a" description))]
    [(expect:atom (? symbol? atom) _)
     (format "expected the literal symbol `~s'" atom)]
    [(expect:atom atom _)
     (format "expected the literal ~s" atom)]
    [(expect:literal literal _)
     (format "expected the identifier `~s'" (syntax-e literal))]
    [(expect:message message _)
     message]
    [(expect:proper-pair '#f _)
     "expected more terms"]))

;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
(define (prose-for-proper-pair-expects es)
  (define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
  (cond [(for/or ([desc descs]) (equal? desc #f))
         ;; FIXME: better way to indicate unknown ???
         "expected more terms"]
        [else
         (format "expected more terms starting with ~a"
                 (join-sep (map prose-for-first-desc descs)
                           "," "or"))]))

;; prose-for-first-desc : FirstDesc -> string
(define (prose-for-first-desc desc)
  (match desc
    [(? string?) desc]
    [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
    [(list 'literal id) (format "the identifier `~s'" id)]
    [(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)]
    [(list 'datum d) (format "the literal ~s" d)]))

;; context-prose-for-expect : (U '... expect:thing) -> (listof string)
(define (context-prose-for-expect e)
  (match e
    ['...
     (list "while parsing different things...")]
    [(expect:thing '#f description transparent? role stx+index)
     (let-values ([(stx _within-stx) (stx+index->at+within stx+index)])
       (cons (~a "while parsing " description
                 (if role (~a " for " role) ""))
             (if (error-print-source-location)
                 (list (~a " term: "
                           (~s (syntax->datum stx)
                               #:limit-marker "..."
                               #:max-width 50))
                       (~a " location: "
                           (or (source-location->string stx) "not available")))
                 null)))]))


;; ============================================================
;; Raise exception

(define (error/report ctx report)
  (let* ([message (report-message report)]
         [context (report-context report)]
         [stx (cadr ctx)]
         [who (or (car ctx) (infer-who stx))]
         [sub-stx (report-stx report)]
         [within-stx (report-within-stx report)]
         [message
          (format "~a: ~a~a~a~a~a"
                  who message
                  (format-if "at" (stx-if-loc sub-stx))
                  (format-if "within" (stx-if-loc within-stx))
                  (format-if "in" (stx-if-loc stx))
                  (if (null? context)
                      ""
                      (apply string-append
                             "\n  parsing context: "
                             (for/list ([c (in-list context)])
                               (format "\n   ~a" c)))))]
         [message
          (if (error-print-source-location)
              (let ([source-stx (or stx sub-stx within-stx)])
                (string-append (source-location->prefix source-stx) message))
              message)])
    (raise
     (exn:fail:syntax message (current-continuation-marks)
                      (map syntax-taint
                           (cond [within-stx (list within-stx)]
                                 [sub-stx (list sub-stx)]
                                 [stx (list stx)]
                                 [else null]))))))

(define (format-if prefix val)
  (if val
      (format "\n  ~a: ~a" prefix val)
      ""))

(define (stx-if-loc stx)
  (and (syntax? stx)
       (error-print-source-location)
       (format "~.s" (syntax->datum stx))))

(define (infer-who stx)
  (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
    (if (identifier? maybe-id) (syntax-e maybe-id) '?)))

(define (comma-list items)
  (join-sep items "," "or"))

(define (improper-stx->list stx)
  (syntax-case stx ()
    [(a . b) (cons #'a (improper-stx->list #'b))]
    [() null]
    [rest (list #'rest)]))


;; ============================================================
;; Debugging

(provide failureset->sexpr
         failure->sexpr
         expectstack->sexpr
         expect->sexpr)

(define (failureset->sexpr fs)
  (let ([fs (flatten fs)])
    (case (length fs)
      ((1) (failure->sexpr (car fs)))
      (else `(union ,@(map failure->sexpr fs))))))

(define (failure->sexpr f)
  (match f
    [(failure progress expectstack)
     `(failure ,(progress->sexpr progress)
               #:expected ,(expectstack->sexpr expectstack))]))

(define (expectstack->sexpr es)
  (map expect->sexpr es))

(define (expect->sexpr e) e)

(define (progress->sexpr ps)
  (for/list ([pf (in-list ps)])
    (match pf
      [(? syntax? stx) 'stx]
      [_ pf])))