runtime-report.rkt (31482B)
1 #lang racket/base 2 (require racket/list 3 racket/format 4 syntax/stx 5 racket/struct 6 syntax/srcloc 7 syntax/parse/private/minimatch 8 stxparse-info/parse/private/residual 9 syntax/parse/private/kws) 10 (provide call-current-failure-handler 11 current-failure-handler 12 invert-failure 13 maximal-failures 14 invert-ps 15 ps->stx+index) 16 17 #| 18 TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f), 19 simplify to (expect:thing _ D _ #f) 20 thus, "expected D" rather than "expected D or D for R" (?) 21 |# 22 23 #| 24 Note: there is a cyclic dependence between residual.rkt and this module, 25 broken by a lazy-require of this module into residual.rkt 26 |# 27 28 (define (call-current-failure-handler ctx fs) 29 (call-with-values (lambda () ((current-failure-handler) ctx fs)) 30 (lambda vals 31 (error 'current-failure-handler 32 "current-failure-handler: did not escape, produced ~e" 33 (case (length vals) 34 ((1) (car vals)) 35 (else (cons 'values vals))))))) 36 37 (define (default-failure-handler ctx fs) 38 (handle-failureset ctx fs)) 39 40 (define current-failure-handler 41 (make-parameter default-failure-handler)) 42 43 44 ;; ============================================================ 45 ;; Processing failure sets 46 47 #| 48 We use progress to select the maximal failures and determine the syntax 49 they're complaining about. After that, we no longer care about progress. 50 51 Old versions of syntax-parse (through 6.4) grouped failures into 52 progress-equivalence-classes and generated reports by class, but only showed 53 one report. New syntax-parse just mixes all maximal failures together and 54 deals with the fact that they might not be talking about the same terms. 55 |# 56 57 ;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes 58 (define (handle-failureset ctx fs) 59 (define inverted-fs (map invert-failure (reverse (flatten fs)))) 60 (define maximal-classes (maximal-failures inverted-fs)) 61 (define ess (map failure-expectstack (append* maximal-classes))) 62 (define report (report/sync-shared ess)) 63 ;; Hack: alternative to new (primitive) phase-crossing exn type is to store 64 ;; extra information in exn continuation marks. Currently for debugging only. 65 (with-continuation-mark 'syntax-parse-error 66 (hasheq 'raw-failures fs 67 'maximal maximal-classes) 68 (error/report ctx report))) 69 70 ;; An RFailure is (failure IPS RExpectList) 71 72 ;; invert-failure : Failure -> RFailure 73 (define (invert-failure f) 74 (match f 75 [(failure ps es) 76 (failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))])) 77 78 ;; A Report is (report String (Listof String) Syntax/#f Syntax/#f) 79 (define-struct report (message context stx within-stx) #:prefab) 80 81 ;; Sometimes the point where an error occurred does not correspond to 82 ;; a syntax object within the original term being matched. We use one 83 ;; or two syntax objects to identify where an error occurred: 84 ;; - the "at" term is the specific point of error, coerced to a syntax 85 ;; object if it isn't already 86 ;; - the "within" term is the closest enclosing original syntax object, 87 ;; dropped (#f) if same as "at" term 88 89 ;; Examples (AT is pre-coercion): 90 ;; TERM PATTERN => AT WITHIN 91 ;; #'(1) (a:id) #'1 -- ;; the happy case 92 ;; #'(1) (a b) () #'(1) ;; tail of syntax list, too short 93 ;; #'(1 . ()) (a b) #'() -- ;; tail is already syntax 94 ;; #'#(1) #(a b) () #'#(1) ;; "tail" of syntax vector 95 ;; #'#s(X 1) #s(X a b) () #'#s(X 1) ;; "tail" of syntax prefab 96 ;; #'(1 2) (a) (#'2) #'(1 2) ;; tail of syntax list, too long 97 98 99 ;; ============================================================ 100 ;; Progress 101 102 ;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure)) 103 (define (maximal-failures fs) 104 (maximal/progress 105 (for/list ([f (in-list fs)]) 106 (cons (failure-progress f) f)))) 107 108 #| 109 Progress ordering 110 ----------------- 111 112 Nearly a lexicographic generalization of partial order on frames. 113 (( CAR < CDR ) || stx ) < POST ) 114 - stx incomparable except with self 115 116 But ORD prefixes are sorted out (and discarded) before comparison with 117 rest of progress. Like post, ord comparable only w/in same group: 118 - (ord g n1) < (ord g n2) if n1 < n2 119 - (ord g1 n1) || (ord g2 n2) when g1 != g2 120 121 122 Progress equality 123 ----------------- 124 125 If ps1 = ps2 then both must "blame" the same term, 126 ie (ps->stx+index ps1) = (ps->stx+index ps2). 127 |# 128 129 ;; An Inverted PS (IPS) is a PS inverted for easy comparison. 130 ;; An IPS may not contain any 'opaque frames. 131 132 ;; invert-ps : PS -> IPS 133 ;; Reverse and truncate at earliest 'opaque frame. 134 (define (invert-ps ps) 135 (reverse (ps-truncate-opaque ps))) 136 137 ;; ps-truncate-opaque : PS -> PS 138 ;; Returns maximal tail with no 'opaque frame. 139 (define (ps-truncate-opaque ps) 140 (let loop ([ps ps] [acc ps]) 141 ;; acc is the biggest tail that has not been seen to contain 'opaque 142 (cond [(null? ps) acc] 143 [(eq? (car ps) 'opaque) 144 (loop (cdr ps) (cdr ps))] 145 [else (loop (cdr ps) acc)]))) 146 147 ;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A)) 148 ;; Eliminates As with non-maximal progress, then groups As into 149 ;; equivalence classes according to progress. 150 (define (maximal/progress items) 151 (cond [(null? items) 152 null] 153 [(null? (cdr items)) 154 (list (list (cdr (car items))))] 155 [else 156 (let loop ([items items] [non-ORD-items null]) 157 (define-values (ORD non-ORD) 158 (partition (lambda (item) (ord? (item-first-prf item))) items)) 159 (cond [(pair? ORD) 160 (loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))] 161 [else 162 (maximal/prf1 (append non-ORD non-ORD-items))]))])) 163 164 ;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A)) 165 (define (maximal/prf1 items) 166 (define-values (POST rest1) 167 (partition (lambda (item) (eq? 'post (item-first-prf item))) items)) 168 (cond [(pair? POST) 169 (maximal/progress (map item-pop-prf POST))] 170 [else 171 (define-values (STX rest2) 172 (partition (lambda (item) (syntax? (item-first-prf item))) rest1)) 173 (define-values (CDR rest3) 174 (partition (lambda (item) (exact-integer? (item-first-prf item))) rest2)) 175 (define-values (CAR rest4) 176 (partition (lambda (item) (eq? 'car (item-first-prf item))) rest3)) 177 (define-values (NULL rest5) 178 (partition (lambda (item) (eq? '#f (item-first-prf item))) rest4)) 179 (unless (null? rest5) 180 (error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5)) 181 (cond [(pair? CDR) 182 (define leastCDR (apply min (map item-first-prf CDR))) 183 (append 184 (maximal/stx STX) 185 (maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))] 186 [(pair? CAR) 187 (append 188 (maximal/stx STX) 189 (maximal/progress (map item-pop-prf CAR)))] 190 [(pair? STX) 191 (maximal/stx STX)] 192 [(pair? NULL) 193 (list (map cdr NULL))] 194 [else null])])) 195 196 ;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A)) 197 ;; PRE: each item has ORD first frame 198 ;; Keep only maximal by first frame and pop first frame from each item. 199 (define (maximal-prf1/ord items) 200 ;; groups : (NEListof (NEListof (cons A IPS))) 201 (define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items)) 202 (append* 203 (for/list ([group (in-list groups)]) 204 (define group* (filter-max group (lambda (item) (ord-index (item-first-prf item))))) 205 (map item-pop-prf group*)))) 206 207 ;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A)) 208 ;; PRE: Each IPS starts with a stx frame. 209 (define (maximal/stx items) 210 ;; groups : (Listof (Listof (cons IPS A))) 211 (define groups (group-by item-first-prf items)) 212 (append* 213 (for/list ([group (in-list groups)]) 214 (maximal/progress (map item-pop-prf group))))) 215 216 ;; filter-max : (Listof X) (X -> Nat) -> (Listof X) 217 (define (filter-max xs x->nat) 218 (let loop ([xs xs] [nmax -inf.0] [r-keep null]) 219 (cond [(null? xs) 220 (reverse r-keep)] 221 [else 222 (define n0 (x->nat (car xs))) 223 (cond [(> n0 nmax) 224 (loop (cdr xs) n0 (list (car xs)))] 225 [(= n0 nmax) 226 (loop (cdr xs) nmax (cons (car xs) r-keep))] 227 [else 228 (loop (cdr xs) nmax r-keep)])]))) 229 230 ;; item-first-prf : (cons IPS A) -> prframe/#f 231 (define (item-first-prf item) 232 (define ips (car item)) 233 (and (pair? ips) (car ips))) 234 235 ;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A)) 236 (define (item-split-ord item) 237 (define ips (car item)) 238 (define a (cdr item)) 239 (define-values (rest-ips r-ord) 240 (let loop ([ips ips] [r-ord null]) 241 (cond [(and (pair? ips) (ord? (car ips))) 242 (loop (cdr ips) (cons (car ips) r-ord))] 243 [else (values ips r-ord)]))) 244 (list* (reverse r-ord) rest-ips a)) 245 246 ;; item-pop-prf : (cons IPS A) -> (cons IPS A) 247 (define (item-pop-prf item) 248 (let ([ips (car item)] 249 [a (cdr item)]) 250 (cons (cdr ips) a))) 251 252 ;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A) 253 ;; Assumes first frame is nat > ncdrs. 254 (define (item-pop-prf-ncdrs item ncdrs) 255 (let ([ips (car item)] 256 [a (cdr item)]) 257 (cond [(= (car ips) ncdrs) (cons (cdr ips) a)] 258 [else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)]))) 259 260 ;; StxIdx = (cons Syntax Nat), the "within" term and offset (#cdrs) of "at" subterm 261 262 ;; ps->stx+index : Progress -> StxIdx 263 ;; Gets the innermost stx that should have a real srcloc, and the offset 264 ;; (number of cdrs) within that where the progress ends. 265 (define (ps->stx+index ps) 266 (define (interp ps top?) 267 ;; if top?: first frame is 'car, must return Syntax, don't unwrap vector/struct 268 (match ps 269 [(cons (? syntax? stx) _) stx] 270 [(cons 'car parent) 271 (let* ([x (interp parent #f)] 272 [d (if (syntax? x) (syntax-e x) x)]) 273 (cond [(pair? d) (car d)] 274 [(vector? d) 275 (if top? x (vector->list d))] 276 [(box? d) (unbox d)] 277 [(prefab-struct-key d) 278 (if top? x (struct->list d))] 279 [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))] 280 [(cons (? exact-positive-integer? n) parent) 281 (for/fold ([stx (interp parent #f)]) ([i (in-range n)]) 282 (stx-cdr stx))] 283 [(cons (? ord?) parent) 284 (interp parent top?)] 285 [(cons 'post parent) 286 (interp parent top?)])) 287 (let loop ([ps (ps-truncate-opaque ps)]) 288 (match ps 289 [(cons (? syntax? stx) _) 290 (cons stx 0)] 291 [(cons 'car _) 292 (cons (interp ps #t) 0)] 293 [(cons (? exact-positive-integer? n) parent) 294 (match (loop parent) 295 [(cons stx m) (cons stx (+ m n))])] 296 [(cons (? ord?) parent) 297 (loop parent)] 298 [(cons 'post parent) 299 (loop parent)]))) 300 301 ;; stx+index->at+within : StxIdx -> (values Syntax Syntax/#f) 302 (define (stx+index->at+within stx+index) 303 (define within-stx (car stx+index)) 304 (define index (cdr stx+index)) 305 (cond [(zero? index) 306 (values within-stx #f)] 307 [else 308 (define d (syntax-e within-stx)) 309 (define stx* 310 (cond [(vector? d) (vector->list d)] 311 [(prefab-struct-key d) (struct->list d)] 312 [else within-stx])) 313 (define at-stx* 314 (for/fold ([x stx*]) ([_i (in-range index)]) (stx-cdr x))) 315 (values (datum->syntax within-stx at-stx* within-stx) 316 within-stx)])) 317 318 ;; ============================================================ 319 ;; Expectation simplification 320 321 ;; normalize-expectstack : ExpectStack StxIdx -> ExpectList 322 ;; Converts to list, converts expect:thing term rep, and truncates 323 ;; expectstack after opaque (ie, transparent=#f) frames. 324 (define (normalize-expectstack es stx+index [truncate-opaque? #t]) 325 (reverse (invert-expectstack es stx+index truncate-opaque?))) 326 327 ;; invert-expectstack : ExpectStack StxIdx -> RExpectList 328 ;; Converts to reversed list, converts expect:thing term rep, 329 ;; and truncates expectstack after opaque (ie, transparent=#f) frames. 330 (define (invert-expectstack es stx+index [truncate-opaque? #t]) 331 (let loop ([es es] [acc null]) 332 (match es 333 ['#f acc] 334 ['#t acc] 335 [(expect:thing ps desc tr? role rest-es) 336 (let* (;; discard frames so far if opaque 337 [acc (if (and truncate-opaque? (not tr?)) null acc)] 338 ;; discard this frame if desc is #f 339 [acc (if desc (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc) acc)]) 340 (loop rest-es acc))] 341 [(expect:message message rest-es) 342 (loop rest-es (cons (expect:message message stx+index) acc))] 343 [(expect:atom atom rest-es) 344 (loop rest-es (cons (expect:atom atom stx+index) acc))] 345 [(expect:literal literal rest-es) 346 (loop rest-es (cons (expect:literal literal stx+index) acc))] 347 [(expect:proper-pair first-desc rest-es) 348 (loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))]))) 349 350 ;; expect->stxidx : Expect -> StxIdx 351 (define (expect->stxidx e) 352 (cond [(expect:thing? e) (expect:thing-next e)] 353 [(expect:message? e) (expect:message-next e)] 354 [(expect:atom? e) (expect:atom-next e)] 355 [(expect:literal? e) (expect:literal-next e)] 356 [(expect:proper-pair? e) (expect:proper-pair-next e)] 357 [(expect:disj? e) (expect:disj-next e)])) 358 359 #| Simplification 360 361 A list of ExpectLists represents a tree, with shared tails meaning shared 362 branches of the tree. We need a "reasonable" way to simplify it to a list to 363 show to the user. Here we develop "reasonable" by example. (It would be nice, 364 of course, to also have some way of exploring the full failure trees.) 365 366 Notation: [A B X] means an ExpectList with class/description A at root and X 367 at leaf. If the term sequences differ, write [t1:A ...] etc. 368 369 Options: 370 (o) = "old behavior (through 6.4)" 371 (f) = "first divergence" 372 (s) = "sync on shared" 373 374 Case 1: [A B X], [A B Y] 375 376 This is nearly the ideal situation: report as 377 378 expected X or Y, while parsing B, while parsing A 379 380 Case 2: [A X], [A] 381 382 For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()], 383 but we don't want to see "expected ()". 384 385 So simplify to [A]---that is, drop X. 386 387 But there are other cases that are more problematic. 388 389 Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y] 390 391 Could report as: 392 (o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors) 393 (f) expected B or C for t2, while parsing t1 as A 394 (x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A 395 396 (o) is not good 397 (b) loses the most specific error information 398 (x) implies spurious contexts (eg, X while parsing C) 399 400 I like (b) best for this situation, but ... 401 402 Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y] 403 404 Could report as: 405 (f') expected B or C, while parsing t1 as A 406 (s) expected X or Y for t4, while ..., while parsing t1 as A 407 (f) expected A for t1 408 409 (f') is problematic, since terms are different! 410 (s) okay, but nothing good to put in that ... space 411 (f) loses a lot of information 412 413 Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y] 414 415 Only feasible choice (no other sync points): 416 (f,s) expected A for t1 417 418 Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y] 419 420 Could report as: 421 (s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A 422 (s) expected X or Y for t3, while ..., while parsing t1 as A 423 424 (s') again implies spurious contexts, bad 425 (s) okay 426 427 Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _] 428 429 Same frames show up in different orders. (Can this really happen? Probably, 430 with very weird uses of ~parse.) 431 432 -- 433 434 This suggests the following new algorithm based on (s): 435 - Step 1: emit an intermediate "unified" expectstack (extended with "..." markers) 436 - make a list (in order) of frames shared by all expectstacks 437 - emit those frames with "..." markers if (sometimes) unshared stuff between 438 - continue processing with the tails after the last shared frame: 439 - find the last term shared by all expectstacks (if any) 440 - find the last frame for that term for each expectstack 441 - combine in expect:disj and emit 442 - Step 2: 443 - remove trailing and collapse adjacent "..." markers 444 445 |# 446 447 ;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList) 448 ;; -> Report 449 (define (report* ess handle-divergence) 450 (define es ;; ExpectList 451 (let loop ([ess ess] [acc null]) 452 (cond [(ormap null? ess) acc] 453 [else 454 (define groups (group-by car ess)) 455 (cond [(singleton? groups) 456 (define group (car groups)) 457 (define frame (car (car group))) 458 (loop (map cdr group) (cons frame acc))] 459 [else ;; found point of divergence 460 (append (handle-divergence groups) acc)])]))) 461 (define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0))) 462 (report/expectstack (clean-up es) stx+index)) 463 464 ;; clean-up : ExpectList -> ExpectList 465 ;; Remove leading and collapse adjacent '... markers 466 (define (clean-up es) 467 (if (and (pair? es) (eq? (car es) '...)) 468 (clean-up (cdr es)) 469 (let loop ([es es]) 470 (cond [(null? es) null] 471 [(eq? (car es) '...) 472 (cons '... (clean-up es))] 473 [else (cons (car es) (loop (cdr es)))])))) 474 475 ;; -- 476 477 ;; report/first-divergence : (NEListof RExpectList) -> Report 478 ;; Generate a single report, using frames from root to first divergence. 479 (define (report/first-divergence ess) 480 (report* ess handle-divergence/first)) 481 482 ;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList 483 (define (handle-divergence/first ess-groups) 484 (define representative-ess (map car ess-groups)) 485 (define first-frames (map car representative-ess)) 486 ;; Do all of the first frames talk about the same term? 487 (cond [(all-equal? (map expect->stxidx first-frames)) 488 (list (expect:disj first-frames #f))] 489 [else null])) 490 491 ;; -- 492 493 ;; report/sync-shared : (NEListof RExpectList) -> Report 494 ;; Generate a single report, syncing on shared frames (and later, terms). 495 (define (report/sync-shared ess) 496 (report* ess handle-divergence/sync-shared)) 497 498 ;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList 499 (define (handle-divergence/sync-shared ess-groups) 500 (define ess (append* ess-groups)) ;; (NEListof RExpectList) 501 (define shared-frames (get-shared ess values)) 502 ;; rsegs : (NEListof (Rev2n+1-Listof RExpectList)) 503 (define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames))) 504 (define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames 505 (define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList)) 506 (append (hd/sync-shared/final final-seg) 507 (hd/sync-shared/ctx ctx-rsegs))) 508 509 ;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList 510 ;; PRE: ess has no shared frames, but may have shared terms. 511 (define (hd/sync-shared/final ess0) 512 (define ess (remove-extensions ess0)) 513 (define shared-terms (get-shared ess expect->stxidx)) 514 (cond [(null? shared-terms) null] 515 [else 516 ;; split at the last shared term 517 (define rsegs ;; (NEListof (3-Listof RExpectList)) 518 (for/list ([es (in-list ess)]) 519 (rsplit es expect->stxidx (list (last shared-terms))))) 520 ;; only care about the got segment and pre, not post 521 (define last-term-ess ;; (NEListof RExpectList) 522 (map cadr rsegs)) 523 (define pre-term-ess ;; (NEListof RExpectList) 524 (map caddr rsegs)) 525 ;; last is most specific 526 (append 527 (list (expect:disj (remove-duplicates (reverse (map last last-term-ess))) 528 (last shared-terms))) 529 (if (ormap pair? pre-term-ess) '(...) '()))])) 530 531 ;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList 532 ;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most. 533 ;; We want leaf-most-first, so just process naturally. 534 (define (hd/sync-shared/ctx rsegs) 535 (let loop ([rsegs rsegs]) 536 (cond [(null? rsegs) null] 537 [(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")] 538 [else (append 539 ;; shared frame: possible for duplicate ctx frames, but unlikely 540 (let ([ess (car rsegs)]) (list (car (car ess)))) 541 ;; inter frames: 542 (let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '())) 543 ;; recur 544 (loop (cddr rsegs)))]))) 545 546 ;; transpose : (Listof (Listof X)) -> (Listof (Listof X)) 547 (define (transpose xss) 548 (cond [(ormap null? xss) null] 549 [else (cons (map car xss) (transpose (map cdr xss)))])) 550 551 ;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y) 552 ;; Return a list of Ys s.t. occur in order in (map of) each xs in xss. 553 (define (get-shared xss get-y) 554 (cond [(null? xss) null] 555 [else 556 (define yhs ;; (Listof (Hash Y => Nat)) 557 (for/list ([xs (in-list xss)]) 558 (for/hash ([x (in-list xs)] [i (in-naturals 1)]) 559 (values (get-y x) i)))) 560 (remove-duplicates 561 (let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)]) 562 ;; last is list of indexes of last accepted y; only accept next if occurs 563 ;; after last in every sequence (see Case 7 above) 564 (cond [(null? xs) null] 565 [else 566 (define y (get-y (car xs))) 567 (define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1))) 568 (cond [(andmap > curr last) 569 (cons y (loop (cdr xs) curr))] 570 [else (loop (cdr xs) last)])])))])) 571 572 ;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X)) 573 ;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1]. 574 ;; Thus the result has 2N+1 elements. The sublists are in original order. 575 (define (rsplit xs get-y ys) 576 (define (loop xs ys segsacc) 577 (cond [(null? ys) (cons xs segsacc)] 578 [else (pre-loop xs ys segsacc null)])) 579 (define (pre-loop xs ys segsacc preacc) 580 (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys))) 581 (got-loop (cdr xs) ys segsacc preacc (list (car xs)))] 582 [else 583 (pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))])) 584 (define (got-loop xs ys segsacc preacc gotacc) 585 (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys))) 586 (got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))] 587 [else 588 (loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))])) 589 (loop xs ys null)) 590 591 ;; singleton? : list -> boolean 592 (define (singleton? x) (and (pair? x) (null? (cdr x)))) 593 594 ;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X)) 595 ;; Remove any element that is an extension of another. 596 (define (remove-extensions xss) 597 (cond [(null? xss) null] 598 [else 599 (let loop ([xss xss]) 600 (cond [(singleton? xss) xss] 601 [(ormap null? xss) (list null)] 602 [else 603 (define groups (group-by car xss)) 604 (append* 605 (for/list ([group (in-list groups)]) 606 (define group* (loop (map cdr group))) 607 (map (lambda (x) (cons (caar group) x)) group*)))]))])) 608 609 ;; all-equal? : (Listof Any) -> Boolean 610 (define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs)))) 611 612 613 ;; ============================================================ 614 ;; Reporting 615 616 ;; report/expectstack : ExpectList StxIdx -> Report 617 (define (report/expectstack es stx+index) 618 (define frame-expect (and (pair? es) (car es))) 619 (define context-frames (if (pair? es) (cdr es) null)) 620 (define context (append* (map context-prose-for-expect context-frames))) 621 (cond [(not frame-expect) 622 (report "bad syntax" context #f #f)] 623 [else 624 (define-values (frame-stx within-stx) (stx+index->at+within stx+index)) 625 (cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f]) 626 (stx-pair? frame-stx)) 627 (report "unexpected term" context (stx-car frame-stx) #f)] 628 [(expect:disj? frame-expect) 629 (report (prose-for-expects (expect:disj-expects frame-expect)) 630 context frame-stx within-stx)] 631 [else 632 (report (prose-for-expects (list frame-expect)) 633 context frame-stx within-stx)])])) 634 635 ;; prose-for-expects : (listof Expect) -> string 636 (define (prose-for-expects expects) 637 (define msgs (filter expect:message? expects)) 638 (define things (filter expect:thing? expects)) 639 (define literal (filter expect:literal? expects)) 640 (define atom/symbol 641 (filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects)) 642 (define atom/nonsym 643 (filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects)) 644 (define proper-pairs (filter expect:proper-pair? expects)) 645 (join-sep 646 (append (map prose-for-expect (append msgs things)) 647 (prose-for-expects/literals literal "identifiers") 648 (prose-for-expects/literals atom/symbol "literal symbols") 649 (prose-for-expects/literals atom/nonsym "literals") 650 (prose-for-expects/pairs proper-pairs)) 651 ";" "or")) 652 653 (define (prose-for-expects/literals expects whats) 654 (cond [(null? expects) null] 655 [(singleton? expects) (map prose-for-expect expects)] 656 [else 657 (define (prose e) 658 (match e 659 [(expect:atom (? symbol? atom) _) 660 (format "`~s'" atom)] 661 [(expect:atom atom _) 662 (format "~s" atom)] 663 [(expect:literal literal _) 664 (format "`~s'" (syntax-e literal))])) 665 (list (string-append "expected one of these " whats ": " 666 (join-sep (map prose expects) "," "or")))])) 667 668 (define (prose-for-expects/pairs expects) 669 (if (pair? expects) (list (prose-for-proper-pair-expects expects)) null)) 670 671 ;; prose-for-expect : Expect -> string 672 (define (prose-for-expect e) 673 (match e 674 [(expect:thing _ description transparent? role _) 675 (if role 676 (format "expected ~a for ~a" description role) 677 (format "expected ~a" description))] 678 [(expect:atom (? symbol? atom) _) 679 (format "expected the literal symbol `~s'" atom)] 680 [(expect:atom atom _) 681 (format "expected the literal ~s" atom)] 682 [(expect:literal literal _) 683 (format "expected the identifier `~s'" (syntax-e literal))] 684 [(expect:message message _) 685 message] 686 [(expect:proper-pair '#f _) 687 "expected more terms"])) 688 689 ;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string 690 (define (prose-for-proper-pair-expects es) 691 (define descs (remove-duplicates (map expect:proper-pair-first-desc es))) 692 (cond [(for/or ([desc descs]) (equal? desc #f)) 693 ;; FIXME: better way to indicate unknown ??? 694 "expected more terms"] 695 [else 696 (format "expected more terms starting with ~a" 697 (join-sep (map prose-for-first-desc descs) 698 "," "or"))])) 699 700 ;; prose-for-first-desc : FirstDesc -> string 701 (define (prose-for-first-desc desc) 702 (match desc 703 [(? string?) desc] 704 [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ??? 705 [(list 'literal id) (format "the identifier `~s'" id)] 706 [(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)] 707 [(list 'datum d) (format "the literal ~s" d)])) 708 709 ;; context-prose-for-expect : (U '... expect:thing) -> (listof string) 710 (define (context-prose-for-expect e) 711 (match e 712 ['... 713 (list "while parsing different things...")] 714 [(expect:thing '#f description transparent? role stx+index) 715 (let-values ([(stx _within-stx) (stx+index->at+within stx+index)]) 716 (cons (~a "while parsing " description 717 (if role (~a " for " role) "")) 718 (if (error-print-source-location) 719 (list (~a " term: " 720 (~s (syntax->datum stx) 721 #:limit-marker "..." 722 #:max-width 50)) 723 (~a " location: " 724 (or (source-location->string stx) "not available"))) 725 null)))])) 726 727 728 ;; ============================================================ 729 ;; Raise exception 730 731 (define (error/report ctx report) 732 (let* ([message (report-message report)] 733 [context (report-context report)] 734 [stx (cadr ctx)] 735 [who (or (car ctx) (infer-who stx))] 736 [sub-stx (report-stx report)] 737 [within-stx (report-within-stx report)] 738 [message 739 (format "~a: ~a~a~a~a~a" 740 who message 741 (format-if "at" (stx-if-loc sub-stx)) 742 (format-if "within" (stx-if-loc within-stx)) 743 (format-if "in" (stx-if-loc stx)) 744 (if (null? context) 745 "" 746 (apply string-append 747 "\n parsing context: " 748 (for/list ([c (in-list context)]) 749 (format "\n ~a" c)))))] 750 [message 751 (if (error-print-source-location) 752 (let ([source-stx (or stx sub-stx within-stx)]) 753 (string-append (source-location->prefix source-stx) message)) 754 message)]) 755 (raise 756 (exn:fail:syntax message (current-continuation-marks) 757 (map syntax-taint 758 (cond [within-stx (list within-stx)] 759 [sub-stx (list sub-stx)] 760 [stx (list stx)] 761 [else null])))))) 762 763 (define (format-if prefix val) 764 (if val 765 (format "\n ~a: ~a" prefix val) 766 "")) 767 768 (define (stx-if-loc stx) 769 (and (syntax? stx) 770 (error-print-source-location) 771 (format "~.s" (syntax->datum stx)))) 772 773 (define (infer-who stx) 774 (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)]) 775 (if (identifier? maybe-id) (syntax-e maybe-id) '?))) 776 777 (define (comma-list items) 778 (join-sep items "," "or")) 779 780 (define (improper-stx->list stx) 781 (syntax-case stx () 782 [(a . b) (cons #'a (improper-stx->list #'b))] 783 [() null] 784 [rest (list #'rest)])) 785 786 787 ;; ============================================================ 788 ;; Debugging 789 790 (provide failureset->sexpr 791 failure->sexpr 792 expectstack->sexpr 793 expect->sexpr) 794 795 (define (failureset->sexpr fs) 796 (let ([fs (flatten fs)]) 797 (case (length fs) 798 ((1) (failure->sexpr (car fs))) 799 (else `(union ,@(map failure->sexpr fs)))))) 800 801 (define (failure->sexpr f) 802 (match f 803 [(failure progress expectstack) 804 `(failure ,(progress->sexpr progress) 805 #:expected ,(expectstack->sexpr expectstack))])) 806 807 (define (expectstack->sexpr es) 808 (map expect->sexpr es)) 809 810 (define (expect->sexpr e) e) 811 812 (define (progress->sexpr ps) 813 (for/list ([pf (in-list ps)]) 814 (match pf 815 [(? syntax? stx) 'stx] 816 [_ pf])))