runtime-report.rkt (31441B)
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 (cond [(and truncate-opaque? (not tr?)) 337 (loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))] 338 [else 339 (loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc))])] 340 [(expect:message message rest-es) 341 (loop rest-es (cons (expect:message message stx+index) acc))] 342 [(expect:atom atom rest-es) 343 (loop rest-es (cons (expect:atom atom stx+index) acc))] 344 [(expect:literal literal rest-es) 345 (loop rest-es (cons (expect:literal literal stx+index) acc))] 346 [(expect:proper-pair first-desc rest-es) 347 (loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))]))) 348 349 ;; expect->stxidx : Expect -> StxIdx 350 (define (expect->stxidx e) 351 (cond [(expect:thing? e) (expect:thing-next e)] 352 [(expect:message? e) (expect:message-next e)] 353 [(expect:atom? e) (expect:atom-next e)] 354 [(expect:literal? e) (expect:literal-next e)] 355 [(expect:proper-pair? e) (expect:proper-pair-next e)] 356 [(expect:disj? e) (expect:disj-next e)])) 357 358 #| Simplification 359 360 A list of ExpectLists represents a tree, with shared tails meaning shared 361 branches of the tree. We need a "reasonable" way to simplify it to a list to 362 show to the user. Here we develop "reasonable" by example. (It would be nice, 363 of course, to also have some way of exploring the full failure trees.) 364 365 Notation: [A B X] means an ExpectList with class/description A at root and X 366 at leaf. If the term sequences differ, write [t1:A ...] etc. 367 368 Options: 369 (o) = "old behavior (through 6.4)" 370 (f) = "first divergence" 371 (s) = "sync on shared" 372 373 Case 1: [A B X], [A B Y] 374 375 This is nearly the ideal situation: report as 376 377 expected X or Y, while parsing B, while parsing A 378 379 Case 2: [A X], [A] 380 381 For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()], 382 but we don't want to see "expected ()". 383 384 So simplify to [A]---that is, drop X. 385 386 But there are other cases that are more problematic. 387 388 Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y] 389 390 Could report as: 391 (o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors) 392 (f) expected B or C for t2, while parsing t1 as A 393 (x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A 394 395 (o) is not good 396 (b) loses the most specific error information 397 (x) implies spurious contexts (eg, X while parsing C) 398 399 I like (b) best for this situation, but ... 400 401 Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y] 402 403 Could report as: 404 (f') expected B or C, while parsing t1 as A 405 (s) expected X or Y for t4, while ..., while parsing t1 as A 406 (f) expected A for t1 407 408 (f') is problematic, since terms are different! 409 (s) okay, but nothing good to put in that ... space 410 (f) loses a lot of information 411 412 Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y] 413 414 Only feasible choice (no other sync points): 415 (f,s) expected A for t1 416 417 Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y] 418 419 Could report as: 420 (s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A 421 (s) expected X or Y for t3, while ..., while parsing t1 as A 422 423 (s') again implies spurious contexts, bad 424 (s) okay 425 426 Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _] 427 428 Same frames show up in different orders. (Can this really happen? Probably, 429 with very weird uses of ~parse.) 430 431 -- 432 433 This suggests the following new algorithm based on (s): 434 - Step 1: emit an intermediate "unified" expectstack (extended with "..." markers) 435 - make a list (in order) of frames shared by all expectstacks 436 - emit those frames with "..." markers if (sometimes) unshared stuff between 437 - continue processing with the tails after the last shared frame: 438 - find the last term shared by all expectstacks (if any) 439 - find the last frame for that term for each expectstack 440 - combine in expect:disj and emit 441 - Step 2: 442 - remove trailing and collapse adjacent "..." markers 443 444 |# 445 446 ;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList) 447 ;; -> Report 448 (define (report* ess handle-divergence) 449 (define es ;; ExpectList 450 (let loop ([ess ess] [acc null]) 451 (cond [(ormap null? ess) acc] 452 [else 453 (define groups (group-by car ess)) 454 (cond [(singleton? groups) 455 (define group (car groups)) 456 (define frame (car (car group))) 457 (loop (map cdr group) (cons frame acc))] 458 [else ;; found point of divergence 459 (append (handle-divergence groups) acc)])]))) 460 (define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0))) 461 (report/expectstack (clean-up es) stx+index)) 462 463 ;; clean-up : ExpectList -> ExpectList 464 ;; Remove leading and collapse adjacent '... markers 465 (define (clean-up es) 466 (if (and (pair? es) (eq? (car es) '...)) 467 (clean-up (cdr es)) 468 (let loop ([es es]) 469 (cond [(null? es) null] 470 [(eq? (car es) '...) 471 (cons '... (clean-up es))] 472 [else (cons (car es) (loop (cdr es)))])))) 473 474 ;; -- 475 476 ;; report/first-divergence : (NEListof RExpectList) -> Report 477 ;; Generate a single report, using frames from root to first divergence. 478 (define (report/first-divergence ess) 479 (report* ess handle-divergence/first)) 480 481 ;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList 482 (define (handle-divergence/first ess-groups) 483 (define representative-ess (map car ess-groups)) 484 (define first-frames (map car representative-ess)) 485 ;; Do all of the first frames talk about the same term? 486 (cond [(all-equal? (map expect->stxidx first-frames)) 487 (list (expect:disj first-frames #f))] 488 [else null])) 489 490 ;; -- 491 492 ;; report/sync-shared : (NEListof RExpectList) -> Report 493 ;; Generate a single report, syncing on shared frames (and later, terms). 494 (define (report/sync-shared ess) 495 (report* ess handle-divergence/sync-shared)) 496 497 ;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList 498 (define (handle-divergence/sync-shared ess-groups) 499 (define ess (append* ess-groups)) ;; (NEListof RExpectList) 500 (define shared-frames (get-shared ess values)) 501 ;; rsegs : (NEListof (Rev2n+1-Listof RExpectList)) 502 (define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames))) 503 (define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames 504 (define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList)) 505 (append (hd/sync-shared/final final-seg) 506 (hd/sync-shared/ctx ctx-rsegs))) 507 508 ;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList 509 ;; PRE: ess has no shared frames, but may have shared terms. 510 (define (hd/sync-shared/final ess0) 511 (define ess (remove-extensions ess0)) 512 (define shared-terms (get-shared ess expect->stxidx)) 513 (cond [(null? shared-terms) null] 514 [else 515 ;; split at the last shared term 516 (define rsegs ;; (NEListof (3-Listof RExpectList)) 517 (for/list ([es (in-list ess)]) 518 (rsplit es expect->stxidx (list (last shared-terms))))) 519 ;; only care about the got segment and pre, not post 520 (define last-term-ess ;; (NEListof RExpectList) 521 (map cadr rsegs)) 522 (define pre-term-ess ;; (NEListof RExpectList) 523 (map caddr rsegs)) 524 ;; last is most specific 525 (append 526 (list (expect:disj (remove-duplicates (reverse (map last last-term-ess))) 527 (last shared-terms))) 528 (if (ormap pair? pre-term-ess) '(...) '()))])) 529 530 ;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList 531 ;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most. 532 ;; We want leaf-most-first, so just process naturally. 533 (define (hd/sync-shared/ctx rsegs) 534 (let loop ([rsegs rsegs]) 535 (cond [(null? rsegs) null] 536 [(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")] 537 [else (append 538 ;; shared frame: possible for duplicate ctx frames, but unlikely 539 (let ([ess (car rsegs)]) (list (car (car ess)))) 540 ;; inter frames: 541 (let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '())) 542 ;; recur 543 (loop (cddr rsegs)))]))) 544 545 ;; transpose : (Listof (Listof X)) -> (Listof (Listof X)) 546 (define (transpose xss) 547 (cond [(ormap null? xss) null] 548 [else (cons (map car xss) (transpose (map cdr xss)))])) 549 550 ;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y) 551 ;; Return a list of Ys s.t. occur in order in (map of) each xs in xss. 552 (define (get-shared xss get-y) 553 (cond [(null? xss) null] 554 [else 555 (define yhs ;; (Listof (Hash Y => Nat)) 556 (for/list ([xs (in-list xss)]) 557 (for/hash ([x (in-list xs)] [i (in-naturals 1)]) 558 (values (get-y x) i)))) 559 (remove-duplicates 560 (let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)]) 561 ;; last is list of indexes of last accepted y; only accept next if occurs 562 ;; after last in every sequence (see Case 7 above) 563 (cond [(null? xs) null] 564 [else 565 (define y (get-y (car xs))) 566 (define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1))) 567 (cond [(andmap > curr last) 568 (cons y (loop (cdr xs) curr))] 569 [else (loop (cdr xs) last)])])))])) 570 571 ;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X)) 572 ;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1]. 573 ;; Thus the result has 2N+1 elements. The sublists are in original order. 574 (define (rsplit xs get-y ys) 575 (define (loop xs ys segsacc) 576 (cond [(null? ys) (cons xs segsacc)] 577 [else (pre-loop xs ys segsacc null)])) 578 (define (pre-loop xs ys segsacc preacc) 579 (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys))) 580 (got-loop (cdr xs) ys segsacc preacc (list (car xs)))] 581 [else 582 (pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))])) 583 (define (got-loop xs ys segsacc preacc gotacc) 584 (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys))) 585 (got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))] 586 [else 587 (loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))])) 588 (loop xs ys null)) 589 590 ;; singleton? : list -> boolean 591 (define (singleton? x) (and (pair? x) (null? (cdr x)))) 592 593 ;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X)) 594 ;; Remove any element that is an extension of another. 595 (define (remove-extensions xss) 596 (cond [(null? xss) null] 597 [else 598 (let loop ([xss xss]) 599 (cond [(singleton? xss) xss] 600 [(ormap null? xss) (list null)] 601 [else 602 (define groups (group-by car xss)) 603 (append* 604 (for/list ([group (in-list groups)]) 605 (define group* (loop (map cdr group))) 606 (map (lambda (x) (cons (caar group) x)) group*)))]))])) 607 608 ;; all-equal? : (Listof Any) -> Boolean 609 (define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs)))) 610 611 612 ;; ============================================================ 613 ;; Reporting 614 615 ;; report/expectstack : ExpectList StxIdx -> Report 616 (define (report/expectstack es stx+index) 617 (define frame-expect (and (pair? es) (car es))) 618 (define context-frames (if (pair? es) (cdr es) null)) 619 (define context (append* (map context-prose-for-expect context-frames))) 620 (cond [(not frame-expect) 621 (report "bad syntax" context #f #f)] 622 [else 623 (define-values (frame-stx within-stx) (stx+index->at+within stx+index)) 624 (cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f]) 625 (stx-pair? frame-stx)) 626 (report "unexpected term" context (stx-car frame-stx) #f)] 627 [(expect:disj? frame-expect) 628 (report (prose-for-expects (expect:disj-expects frame-expect)) 629 context frame-stx within-stx)] 630 [else 631 (report (prose-for-expects (list frame-expect)) 632 context frame-stx within-stx)])])) 633 634 ;; prose-for-expects : (listof Expect) -> string 635 (define (prose-for-expects expects) 636 (define msgs (filter expect:message? expects)) 637 (define things (filter expect:thing? expects)) 638 (define literal (filter expect:literal? expects)) 639 (define atom/symbol 640 (filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects)) 641 (define atom/nonsym 642 (filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects)) 643 (define proper-pairs (filter expect:proper-pair? expects)) 644 (join-sep 645 (append (map prose-for-expect (append msgs things)) 646 (prose-for-expects/literals literal "identifiers") 647 (prose-for-expects/literals atom/symbol "literal symbols") 648 (prose-for-expects/literals atom/nonsym "literals") 649 (prose-for-expects/pairs proper-pairs)) 650 ";" "or")) 651 652 (define (prose-for-expects/literals expects whats) 653 (cond [(null? expects) null] 654 [(singleton? expects) (map prose-for-expect expects)] 655 [else 656 (define (prose e) 657 (match e 658 [(expect:atom (? symbol? atom) _) 659 (format "`~s'" atom)] 660 [(expect:atom atom _) 661 (format "~s" atom)] 662 [(expect:literal literal _) 663 (format "`~s'" (syntax-e literal))])) 664 (list (string-append "expected one of these " whats ": " 665 (join-sep (map prose expects) "," "or")))])) 666 667 (define (prose-for-expects/pairs expects) 668 (if (pair? expects) (list (prose-for-proper-pair-expects expects)) null)) 669 670 ;; prose-for-expect : Expect -> string 671 (define (prose-for-expect e) 672 (match e 673 [(expect:thing _ description transparent? role _) 674 (if role 675 (format "expected ~a for ~a" description role) 676 (format "expected ~a" description))] 677 [(expect:atom (? symbol? atom) _) 678 (format "expected the literal symbol `~s'" atom)] 679 [(expect:atom atom _) 680 (format "expected the literal ~s" atom)] 681 [(expect:literal literal _) 682 (format "expected the identifier `~s'" (syntax-e literal))] 683 [(expect:message message _) 684 message] 685 [(expect:proper-pair '#f _) 686 "expected more terms"])) 687 688 ;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string 689 (define (prose-for-proper-pair-expects es) 690 (define descs (remove-duplicates (map expect:proper-pair-first-desc es))) 691 (cond [(for/or ([desc descs]) (equal? desc #f)) 692 ;; FIXME: better way to indicate unknown ??? 693 "expected more terms"] 694 [else 695 (format "expected more terms starting with ~a" 696 (join-sep (map prose-for-first-desc descs) 697 "," "or"))])) 698 699 ;; prose-for-first-desc : FirstDesc -> string 700 (define (prose-for-first-desc desc) 701 (match desc 702 [(? string?) desc] 703 [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ??? 704 [(list 'literal id) (format "the identifier `~s'" id)] 705 [(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)] 706 [(list 'datum d) (format "the literal ~s" d)])) 707 708 ;; context-prose-for-expect : (U '... expect:thing) -> (listof string) 709 (define (context-prose-for-expect e) 710 (match e 711 ['... 712 (list "while parsing different things...")] 713 [(expect:thing '#f description transparent? role stx+index) 714 (let-values ([(stx _within-stx) (stx+index->at+within stx+index)]) 715 (cons (~a "while parsing " description 716 (if role (~a " for " role) "")) 717 (if (error-print-source-location) 718 (list (~a " term: " 719 (~s (syntax->datum stx) 720 #:limit-marker "..." 721 #:max-width 50)) 722 (~a " location: " 723 (or (source-location->string stx) "not available"))) 724 null)))])) 725 726 727 ;; ============================================================ 728 ;; Raise exception 729 730 (define (error/report ctx report) 731 (let* ([message (report-message report)] 732 [context (report-context report)] 733 [stx (cadr ctx)] 734 [who (or (car ctx) (infer-who stx))] 735 [sub-stx (report-stx report)] 736 [within-stx (report-within-stx report)] 737 [message 738 (format "~a: ~a~a~a~a~a" 739 who message 740 (format-if "at" (stx-if-loc sub-stx)) 741 (format-if "within" (stx-if-loc within-stx)) 742 (format-if "in" (stx-if-loc stx)) 743 (if (null? context) 744 "" 745 (apply string-append 746 "\n parsing context: " 747 (for/list ([c (in-list context)]) 748 (format "\n ~a" c)))))] 749 [message 750 (if (error-print-source-location) 751 (let ([source-stx (or stx sub-stx within-stx)]) 752 (string-append (source-location->prefix source-stx) message)) 753 message)]) 754 (raise 755 (exn:fail:syntax message (current-continuation-marks) 756 (map syntax-taint 757 (cond [within-stx (list within-stx)] 758 [sub-stx (list sub-stx)] 759 [stx (list stx)] 760 [else null])))))) 761 762 (define (format-if prefix val) 763 (if val 764 (format "\n ~a: ~a" prefix val) 765 "")) 766 767 (define (stx-if-loc stx) 768 (and (syntax? stx) 769 (error-print-source-location) 770 (format "~.s" (syntax->datum stx)))) 771 772 (define (infer-who stx) 773 (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)]) 774 (if (identifier? maybe-id) (syntax-e maybe-id) '?))) 775 776 (define (comma-list items) 777 (join-sep items "," "or")) 778 779 (define (improper-stx->list stx) 780 (syntax-case stx () 781 [(a . b) (cons #'a (improper-stx->list #'b))] 782 [() null] 783 [rest (list #'rest)])) 784 785 786 ;; ============================================================ 787 ;; Debugging 788 789 (provide failureset->sexpr 790 failure->sexpr 791 expectstack->sexpr 792 expect->sexpr) 793 794 (define (failureset->sexpr fs) 795 (let ([fs (flatten fs)]) 796 (case (length fs) 797 ((1) (failure->sexpr (car fs))) 798 (else `(union ,@(map failure->sexpr fs)))))) 799 800 (define (failure->sexpr f) 801 (match f 802 [(failure progress expectstack) 803 `(failure ,(progress->sexpr progress) 804 #:expected ,(expectstack->sexpr expectstack))])) 805 806 (define (expectstack->sexpr es) 807 (map expect->sexpr es)) 808 809 (define (expect->sexpr e) e) 810 811 (define (progress->sexpr ps) 812 (for/list ([pf (in-list ps)]) 813 (match pf 814 [(? syntax? stx) 'stx] 815 [_ pf])))