816 lines
31 KiB
Plaintext
816 lines
31 KiB
Plaintext
#lang racket/base
|
|
(require racket/list
|
|
racket/format
|
|
syntax/stx
|
|
racket/struct
|
|
syntax/srcloc
|
|
syntax/parse/private/minimatch
|
|
stxparse-info/parse/private/residual
|
|
syntax/parse/private/kws)
|
|
(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)
|
|
(cond [(and truncate-opaque? (not tr?))
|
|
(loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]
|
|
[else
|
|
(loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) 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])))
|