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