suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Updated non-default probabilities to include may-use counter

Browse Source 
Updated error formatting to report more information in some ties, and reduce
repetitivness

svn: r7041
This commit is contained in:
Kathy Gray 2007-08-07 01:54:52 +00:00
parent 348d0c2acb
commit 2c69de141b
2 changed files with 234 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/combinator-parser/private-combinator/combinator.scm
View File

@ -200,29 +200,30 @@
#;(printf "seq-walker called: else case, ~a case of ~a ~ath case ~n" #;(printf "seq-walker called: else case, ~a case of ~a ~ath case ~n"
seq-name (curr-pred return-name) (length seen)) seq-name (curr-pred return-name) (length seen))
(let ([fst (curr-pred input last-src)]) (let ([fst (curr-pred input last-src)])
#;(printf "seq-walker predicate returned~n")
(cond (cond
[(res? fst) [(res? fst)
#;(!!! (printf "res case ~a ~a~n" seq-name (length seen)))
(cond (cond
[(res-a fst) (next-call fst fst (res-msg fst) [(res-a fst) (next-call fst fst (res-msg fst)
(and id-spot? (res-id fst)) (and id-spot? (res-id fst))
(res-first-tok fst) alts)] (res-first-tok fst) alts)]
[else [else
#;(printf "error situation~n") #;(printf "error situation ~a ~a~n" seq-name (length seen))
(build-error fst (previous? input) (previous? return-name) (build-error fst (previous? input) (previous? return-name)
(car next-preds) look-back used curr-id (car next-preds) look-back used curr-id
seen alts last-src)])] seen alts last-src)])]
[(repeat-res? fst) [(repeat-res? fst)
#;(!!! (printf "repeat-res: ~n")) #;(!!! (printf "repeat-res: ~a ~a~n" seq-name (length seen)))
#;(!!! (printf "res? ~a~n" (res? (repeat-res-a fst)))) #;(!!! (printf "res? ~a~n" (res? (repeat-res-a fst))))
(next-call (repeat-res-a fst) fst (next-call (repeat-res-a fst) fst
(res-msg (repeat-res-a fst)) #f (res-msg (repeat-res-a fst)) #f
(res-first-tok (repeat-res-a fst)) alts)] (res-first-tok (repeat-res-a fst)) alts)]
[(or (choice-res? fst) (pair? fst)) [(or (choice-res? fst) (pair? fst))
#;(printf "choice-res or pair: ~a ~a ~a ~n" #;(!!! (printf "choice-res or pair: ~a ~a ~a~n"
(choice-res? fst) (choice-res? fst)
(if (choice-res? fst) (map res-rest (choice-res-matches fst)) fst) seq-name (length seen)
(if (choice-res? fst) (map res-a (choice-res-matches fst)) fst)) #;(if (choice-res? fst) (map res-rest (choice-res-matches fst)) fst)
#;(if (choice-res? fst) (map res-a (choice-res-matches fst)) fst)))
(let*-values (let*-values
([(lst name curr) ([(lst name curr)
(if (choice-res? fst) (if (choice-res? fst)
@ -235,12 +236,13 @@
(map (lambda (res) (map (lambda (res)
(cond (cond
[(res? res) [(res? res)
#;(!!! (printf "choice-res, res ~a ~a~n" seq-name (length seen)))
(next-call res (curr res) (name res) (next-call res (curr res) (name res)
(and id-spot? (res-id res)) (and id-spot? (res-id res))
(res-first-tok res) new-alts)] (res-first-tok res) new-alts)]
[(repeat-res? res) [(repeat-res? res)
#;(!!! (printf "choice-res, repeat-res ~a~n" #;(!!! (printf "choice-res, repeat-res ~a ~a ~a~n"
(res? (repeat-res-a res)))) (res? (repeat-res-a res)) seq-name (length seen)))
(next-call (repeat-res-a res) res (next-call (repeat-res-a res) res
(res-msg (repeat-res-a res)) #f (res-msg (repeat-res-a res)) #f
(res-first-tok (repeat-res-a res)) (res-first-tok (repeat-res-a res))
@ -312,13 +314,12 @@
(let ([inn (repeat-res-a rpt)] (let ([inn (repeat-res-a rpt)]
[stop (repeat-res-stop rpt)]) [stop (repeat-res-stop rpt)])
(cond (cond
[stop [(fail-type? stop)
(make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn) (make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn)
(if (and (zero? (res-used inn)) (if (and (zero? (res-used inn))
(choice-res? back) (choice-res-errors back) (choice-res? back) (choice-res-errors back)
(or (not (fail-type? stop))
(> (fail-type-chance (choice-res-errors back)) (> (fail-type-chance (choice-res-errors back))
(fail-type-chance stop)))) (fail-type-chance stop)))
(choice-res-errors back) (choice-res-errors back)
stop) stop)
(res-first-tok inn))] (res-first-tok inn))]
@ -330,13 +331,13 @@
[(or (and (res? old-res) (res-a old-res)) (choice-res? old-res)) [(or (and (res? old-res) (res-a old-res)) (choice-res? old-res))
old-res] old-res]
[(repeat-res? old-res) [(repeat-res? old-res)
#;(!!! (printf "finished on repeat-res for ~a res ~a~n" name old-res)) #;(!!! (printf "finished on repeat-res for ~a res ~n" name #;old-res))
(repeat->res old-res look-back)] (repeat->res old-res look-back)]
[(pair? old-res) [(pair? old-res)
#;(!!! (printf "finished on pairs of res ~a~n" old-res)) #;(!!! (printf "finished on pairs of res for ~a~n" name #;old-res))
(map (lambda (r) (repeat->res r look-back)) old-res)] (map (lambda (r) (repeat->res r look-back)) old-res)]
[else [else
;There actually was an error #;(printf "There actually was an error for ~a~n" name)
(fail-res (res-rest old-res) (fail-res (res-rest old-res)
(let*-values ([(fail) (res-msg old-res)] (let*-values ([(fail) (res-msg old-res)]
[(possible-fail) [(possible-fail)
@ -391,12 +392,19 @@
#;(when (pair? look-back) #;(when (pair? look-back)
(printf "look-back is a pair~n")) (printf "look-back is a pair~n"))
#;(when (res? look-back) #;(when (res? look-back)
(printf "lookback is a res, ~a~n" (fail-type? (res-possible-error look-back)))) (printf "look-back res ~a : ~a vs ~a : ~a > ~a~n"
(fail-type? (res-possible-error look-back))
(and (fail-type? (res-possible-error look-back)) (fail-type-name (res-possible-error look-back)))
(fail-type-name (res-msg old-res))
(and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back)))
(fail-type-chance (res-msg old-res))))
(let* ([seq-fail-maker (let* ([seq-fail-maker
(lambda (fail) (lambda (fail)
(let-values ([(kind expected found) (get-fail-info fail)]) (let-values ([(kind expected found) (get-fail-info fail)])
(make-sequence-fail (make-sequence-fail
(compute-chance len seen-len used alts (fail-type-chance fail)) (compute-chance len seen-len used alts
(fail-type-may-use fail)
(fail-type-chance fail))
(fail-type-src fail) (fail-type-src fail)
name used name used
(+ used (fail-type-may-use fail) next-used) (+ used (fail-type-may-use fail) next-used)
@ -406,6 +414,7 @@
[seq-fail (seq-fail-maker fail)] [seq-fail (seq-fail-maker fail)]
[pos-fail (and possible-fail (seq-fail-maker possible-fail))] [pos-fail (and possible-fail (seq-fail-maker possible-fail))]
[opt-fails (list seq-fail pos-fail)]) [opt-fails (list seq-fail pos-fail)])
#;(printf "seq-fail ~a~n" seq-fail)
#;(when pos-fail (printf "opt-fails ~a~n" opt-fails)) #;(when pos-fail (printf "opt-fails ~a~n" opt-fails))
(if pos-fail (if pos-fail
(make-options-fail (rank-choice (map fail-type-chance opt-fails)) (make-options-fail (rank-choice (map fail-type-chance opt-fails))
@ -416,20 +425,27 @@
opt-fails) opt-fails)
seq-fail))))])))) seq-fail))))]))))
(define (compute-chance expected-length seen-length used-toks num-alts sub-chance) (define (compute-chance expected-length seen-length used-toks num-alts may-use sub-chance)
(if (zero? used-toks) #;(when (zero? used-toks)
(* (* (/ 1 expected-length) (/ 1 num-alts)) sub-chance) (printf "compute-chance 0 case: ~a, ~a, ~a, ~a -> ~a~n"
sub-chance expected-length num-alts may-use
(* (/ 1 num-alts) sub-chance)))
(if (and (zero? used-toks) (zero? may-use))
(* (/ 1 expected-length) (/ 1 num-alts) sub-chance)
(let* ([revised-expectation (+ (- used-toks seen-length) expected-length)] (let* ([revised-expectation (+ (- used-toks seen-length) expected-length)]
[probability-with-sub (* (/ (add1 used-toks) revised-expectation) (/ 1 num-alts))] [possible-expectation (+ revised-expectation (max 0 (sub1 may-use)))]
[probability-with-sub (* (/ (+ may-use used-toks) possible-expectation) (/ 1 num-alts))]
#;[probability-with-sub (* (/ (add1 used-toks) revised-expectation) (/ 1 num-alts))]
[probability-without-sub (* (/ used-toks revised-expectation) (/ 1 num-alts))] [probability-without-sub (* (/ used-toks revised-expectation) (/ 1 num-alts))]
[expected-sub probability-with-sub] [expected-sub probability-with-sub]
[expected-no-sub probability-without-sub] [expected-no-sub probability-without-sub]
[probability (/ (* expected-sub sub-chance) (+ (* expected-sub sub-chance) [probability (/ (* expected-sub sub-chance) (+ (* expected-sub sub-chance)
(* expected-no-sub (- 1 sub-chance))))]) (* expected-no-sub (- 1 sub-chance))))])
#;(printf "compute-chance: args ~a ~a ~a ~a ~a~n" #;(printf "compute-chance: args ~a ~a ~a ~a ~a ~a~n"
expected-length seen-length used-toks num-alts sub-chance) expected-length seen-length used-toks num-alts may-use sub-chance)
#;(printf "compute-chance: intermediate values: ~a ~a ~a ~a ~a~n" #;(printf "compute-chance: intermediate values: ~a ~a ~a ~a ~a ~a~n"
revised-expectation probability-with-sub probability-without-sub expected-sub expected-no-sub) revised-expectation possible-expectation probability-with-sub probability-without-sub expected-sub expected-no-sub)
#;(printf "compute-chance answer ~a~n" probability)
probability))) probability)))
;greedy-repeat: (list 'a) -> result -> (list 'a) -> result ;greedy-repeat: (list 'a) -> result -> (list 'a) -> result
@ -446,7 +462,10 @@
(cond (cond
[(res? rest) [(res? rest)
(make-res (append a (res-a rest)) (res-rest rest) repeat-name "" (make-res (append a (res-a rest)) (res-rest rest) repeat-name ""
(+ (res-used curr-ans) (res-used rest)) (res-possible-error rest) (+ (res-used curr-ans) (res-used rest))
(if (fail-type? (repeat-res-stop rest-ans))
(repeat-res-stop rest-ans)
(res-possible-error rest))
(res-first-tok curr-ans))] (res-first-tok curr-ans))]
[(and (pair? rest) (null? (cdr rest))) [(and (pair? rest) (null? (cdr rest)))
(make-res (append a (res-a (car rest))) (res-rest (car rest)) repeat-name "" (make-res (append a (res-a (car rest))) (res-rest (car rest)) repeat-name ""
@ -458,7 +477,9 @@
(map (lambda (rs) (map (lambda (rs)
(make-res (append a (res-a rs)) (res-rest rs) repeat-name "" (make-res (append a (res-a rs)) (res-rest rs) repeat-name ""
(+ (res-used curr-ans) (res-used rs)) (+ (res-used curr-ans) (res-used rs))
(res-possible-error rs) (if (fail-type? (repeat-res-stop rest-ans))
(repeat-res-stop rest-ans)
(res-possible-error rs))
(res-first-tok curr-ans))) (res-first-tok curr-ans)))
rest))]) rest))])
(repeat-res-stop rest-ans)))] (repeat-res-stop rest-ans)))]
@ -488,18 +509,27 @@
repeat-name #;this-res) repeat-name #;this-res)
(cond (cond
[(and (res? this-res) (res-a this-res)) [(and (res? this-res) (res-a this-res))
#;(printf "loop again case~n") #;(printf "loop again case for ~a~n" repeat-name)
(process-rest this-res (loop (res-rest this-res) (process-rest this-res (loop (res-rest this-res)
(update-src (res-rest this-res) curr-src)))] (update-src (res-rest this-res) curr-src)))]
[(res? this-res) [(res? this-res)
#;(printf "fail for error case ~a~n" (fail-type? (res-msg this-res))) #;(printf "fail for error case of ~a: ~a ~a~n"
repeat-name
(cond
[(choice-fail? (res-msg this-res)) 'choice]
[(sequence-fail? (res-msg this-res)) 'seq]
[(options-fail? (res-msg this-res)) 'options]
[else 'terminal])
(fail-type-chance (res-msg this-res)))
(make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f) (make-repeat-res (make-res null curr-input repeat-name "" 0 #f #f)
(res-msg this-res))] (res-msg this-res))]
[(repeat-res? this-res) [(repeat-res? this-res)
#;(printf "repeat-res case of ~a~n" repeat-name)
(process-rest (repeat-res-a this-res) (process-rest (repeat-res-a this-res)
(res-rest (repeat-res-a this-res)))] (res-rest (repeat-res-a this-res)))]
[(or (choice-res? this-res) (pair? this-res)) [(or (choice-res? this-res) (pair? this-res))
#;(printf "repeat call, choice-res ~a~n" #;(printf "repeat call of ~a, choice-res ~a~n"
repeat-name
(and (choice-res? this-res) (and (choice-res? this-res)
(length (choice-res-matches this-res)))) (length (choice-res-matches this-res))))
(map (lambda (match) (process-rest match (map (lambda (match) (process-rest match

124
collects/combinator-parser/private-combinator/errors.scm
View File

@ -27,36 +27,39 @@
#;(printf "fail-type->message ~a~n" fail-type) #;(printf "fail-type->message ~a~n" fail-type)
(cond (cond
[(terminal-fail? fail-type) [(terminal-fail? fail-type)
(combine-message (collapse-message
(add-to-message
(msg (msg
(case (terminal-fail-kind fail-type) (case (terminal-fail-kind fail-type)
[(end) (format "Expected to find ~a ~a, but ~a ended prematurely." [(end) (format "Expected to find ~a ~a, but ~a ended prematurely."
a name input-type)] a name input-type)]
[(wrong) (format "Expected to find ~a ~a, but instead found ~a, which is illegal here." [(wrong) (format "Expected to find ~a ~a, but instead found ~a."
a name (input->output-name (terminal-fail-found fail-type)))] a name (input->output-name (terminal-fail-found fail-type)))]
[(misscase) (format "Expected to find ~a ~a, found ~a which may be miscapitalized." [(misscase) (format "Expected to find ~a ~a, found ~a which may be miscapitalized."
a name (input->output-name (terminal-fail-found fail-type)))] a name (input->output-name (terminal-fail-found fail-type)))]
[(misspell) (format "Expected to find ~a ~a, found ~a which seems to be misspelled." [(misspell) (format "Expected to find ~a ~a, found ~a which may be misspelled."
a name (input->output-name (terminal-fail-found fail-type)))] a name (input->output-name (terminal-fail-found fail-type)))]
[(missclass) (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a." [(missclass) (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a."
(input->output-name (terminal-fail-found fail-type)) a name class-type a name)])) (input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
message-to-date)] name #f message-to-date))]
[(sequence-fail? fail-type) [(sequence-fail? fail-type)
#;(printf "sequence-fail case: kind is ~a~n" (sequence-fail-kind fail-type)) #;(printf "sequence-fail case: kind is ~a~n" (sequence-fail-kind fail-type))
(let* ([id-name (let* ([curr-id (sequence-fail-id fail-type)]
(if (sequence-fail-id fail-type) [id-name
(string-append name " " (sequence-fail-id fail-type)) name)] (if curr-id (string-append name " " (sequence-fail-id fail-type)) name)]
[expected (sequence-fail-expected fail-type)] [expected (sequence-fail-expected fail-type)]
[a2 (a/an expected)] [a2 (a/an expected)]
[show-sequence (sequence-fail-correct fail-type)]) [show-sequence (sequence-fail-correct fail-type)])
(case (sequence-fail-kind fail-type) (case (sequence-fail-kind fail-type)
[(end) [(end)
(combine-message (collapse-message
(add-to-message
(msg (format "Expected ~a to contain ~a ~a to complete the ~a. ~nFound ~a before ~a ended." (msg (format "Expected ~a to contain ~a ~a to complete the ~a. ~nFound ~a before ~a ended."
input-type a2 expected id-name (format-seen show-sequence) input-type)) input-type a2 expected id-name (format-seen show-sequence) input-type))
message-to-date)] name curr-id message-to-date))]
[(wrong) [(wrong)
(combine-message (collapse-message
(add-to-message
(msg (msg
(cond (cond
[(sequence-fail-repeat? fail-type) [(sequence-fail-repeat? fail-type)
@ -69,22 +72,25 @@
(format "Expected ~a ~a to continue this ~a. Instead, found ~a after ~a." (format "Expected ~a ~a to continue this ~a. Instead, found ~a after ~a."
a2 expected id-name (input->output-name (sequence-fail-found fail-type)) a2 expected id-name (input->output-name (sequence-fail-found fail-type))
(format-seen show-sequence))])) (format-seen show-sequence))]))
message-to-date)] name curr-id message-to-date))]
[(misscase) [(misscase)
(combine-message (collapse-message
(add-to-message
(msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be miscapitalized." (msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be miscapitalized."
a2 expected id-name (input->output-name (sequence-fail-found fail-type)))) a2 expected id-name (input->output-name (sequence-fail-found fail-type))))
message-to-date)] name curr-id message-to-date))]
[(misspell) [(misspell)
(combine-message (collapse-message
(msg (format "Expected to find ~a ~a to continue this ~a, found ~a which seems to be misspelled." (add-to-message
(msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be misspelled."
a2 expected id-name (input->output-name (sequence-fail-found fail-type)))) a2 expected id-name (input->output-name (sequence-fail-found fail-type))))
message-to-date)] name curr-id message-to-date))]
[(missclass) [(missclass)
(combine-message (collapse-message
(msg (format "Found ~a instead of ~a ~a, a ~a cannot be used as a(n) ~a." (add-to-message
(input->output-name (sequence-fail-found fail-type)) a2 expected class-type expected)) (msg (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a."
message-to-date)] (input->output-name (sequence-fail-found fail-type)) a2 expected class-type a2 expected))
name curr-id message-to-date))]
[(sub-seq choice) [(sub-seq choice)
(fail-type->message (sequence-fail-found fail-type) (fail-type->message (sequence-fail-found fail-type)
(add-to-message (msg (format "An error occured in ~a.~n" id-name)) (add-to-message (msg (format "An error occured in ~a.~n" id-name))
@ -94,13 +100,13 @@
(lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))]) (lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))])
(if (null? show-sequence) (if (null? show-sequence)
(fail-type->message (car sorted-opts) (fail-type->message (car sorted-opts)
(add-to-message (msg (format "This ~a did not start as expected." id-name)) (add-to-message (msg (format "This ~a did not begin as expected." id-name))
name (sequence-fail-id fail-type) message-to-date)) name (sequence-fail-id fail-type) message-to-date))
(fail-type->message (car sorted-opts) (fail-type->message (car sorted-opts)
(add-to-message (add-to-message
(msg (format "There is an error in this ~a after ~a, it is likely you intended a(n) ~a here.~n" (msg (format "There is an error in this ~a after ~a, the program resembles a(n) ~a here.~n"
id-name (car (reverse show-sequence)) (fail-type-name (car sorted-opts)))) id-name (car (reverse show-sequence))
(fail-type-name (car sorted-opts))))
name (sequence-fail-id fail-type) message-to-date))))]))] name (sequence-fail-id fail-type) message-to-date))))]))]
[(options-fail? fail-type) [(options-fail? fail-type)
#;(printf "selecting for options on ~a~n" name) #;(printf "selecting for options on ~a~n" name)
@ -112,16 +118,20 @@
[(and (> (length winners) 1) [(and (> (length winners) 1)
(> (length non-dup-tops) 1) (> (length non-dup-tops) 1)
(> (length winners) max-choice-depth)) (> (length winners) max-choice-depth))
(combine-message (collapse-message
(add-to-message
(msg (format "An error occurred in this ~a. Program resembles one of ~a.~n" (msg (format "An error occurred in this ~a. Program resembles one of ~a.~n"
name (nice-list non-dup-tops))) name (nice-list non-dup-tops)))
message-to-date)] name #f message-to-date))]
[(and (> (length winners) 1) [(and (> (length winners) 1)
(<= (length winners) max-choice-depth)) (<= (length winners) max-choice-depth))
(combine-message (let ([messages (map (lambda (f) (fail-type->message f null)) winners)])
(msg (format "An error occured in the ~a, program no longer matches expectation." (collapse-message
name)) (add-to-message
message-to-date)] (msg (format "An error occured in the ~a. Possible errors were: ~n ~a"
name
(alternate-error-list (map err-msg messages))))
name #f message-to-date)))]
[else [else
(fail-type->message (fail-type->message
(car winners) (car winners)
@ -130,7 +140,7 @@
(format "There is an error in this ~a~a.~n" (format "There is an error in this ~a~a.~n"
name name
(if (equal? top-name name) "" (if (equal? top-name name) ""
(format ", it is likely you intended ~a ~a here" (a/an top-name) top-name)))) (format ", program resembles ~a ~a" (a/an top-name) top-name))))
name #f message-to-date))]))] name #f message-to-date))]))]
[(choice-fail? fail-type) [(choice-fail? fail-type)
#;(printf "selecting for ~a~n message-to-date ~a~n" name message-to-date) #;(printf "selecting for ~a~n message-to-date ~a~n" name message-to-date)
@ -141,32 +151,38 @@
(cond (cond
[(and (choice-fail-ended? fail-type) [(and (choice-fail-ended? fail-type)
(> (length winners) 1)) (> (length winners) 1))
(combine-message (collapse-message
(msg (format "Expected a ~a, possible forms are ~a." name (add-to-message
(msg (format "Expected a ~a, possible options are ~a." name
(nice-list (first-n max-choice-depth no-dup-names)))) (nice-list (first-n max-choice-depth no-dup-names))))
message-to-date)] name #f message-to-date))]
[(and (<= (choice-fail-options fail-type) max-choice-depth) [(and (<= (choice-fail-options fail-type) max-choice-depth)
(> (length no-dup-names) 1) (> (length no-dup-names) 1)
(> (length winners) 1) (> (length winners) 1)
(equal? top-names no-dup-names)) (equal? top-names no-dup-names))
(combine-message (collapse-message
(msg (format "An error occured in this ~a, one of ~a is expected here." (add-to-message
(msg (format "An error occured in this ~a, expected one of ~a."
name (nice-list no-dup-names))) name (nice-list no-dup-names)))
message-to-date)] name #f message-to-date))]
[(and (<= (choice-fail-options fail-type) max-choice-depth) [(and (<= (choice-fail-options fail-type) max-choice-depth)
(> (length no-dup-names) 1) (> (length no-dup-names) 1)
(> (length winners) 1)) (> (length winners) 1))
(combine-message (let ([messages (map (lambda (f) (fail-type->message f null)) winners)])
(msg (format "An error occured in this ~a, one of ~a is expected here. Program resembles one of ~a.~n" (collapse-message
name (nice-list no-dup-names) (nice-list top-names))) (add-to-message
message-to-date)] (msg (format "An error occured in this ~a, expected one of ~a. Possible errors were:~n~a"
name (nice-list no-dup-names)
(alternate-error-list (map err-msg messages))))
name #f message-to-date)))]
[(and (> (length no-dup-names) max-choice-depth) [(and (> (length no-dup-names) max-choice-depth)
(> (length winners) 1)) (> (length winners) 1))
(combine-message (collapse-message
(add-to-message
(msg (format "An error occured in this ~a. Possible options are ~a.~n" (msg (format "An error occured in this ~a. Possible options are ~a.~n"
name (nice-list name (nice-list
(first-n max-choice-depth no-dup-names)))) (first-n max-choice-depth no-dup-names))))
message-to-date)] name #f message-to-date))]
[else [else
(fail-type->message (fail-type->message
(car winners) (car winners)
@ -257,6 +273,16 @@
[(null? (cddr l)) (string-append (car l) " or " (cadr l))] [(null? (cddr l)) (string-append (car l) " or " (cadr l))]
[else (formatter l)]))) [else (formatter l)])))
(define (alternate-error-list l)
(cond
[(null? l) ""]
[else
(let ([msg (if (equal? #\newline (string-ref (car l) (sub1 (string-length (car l)))))
(substring (car l) 0 (sub1 (string-length (car l))))
(car l))])
(string-append (format "~a~a~n" #\tab msg)
(alternate-error-list (cdr l))))]))
(define (downcase string) (define (downcase string)
(string-append (string-downcase (substring string 0 1)) (string-append (string-downcase (substring string 0 1))
(substring string 1 (string-length string)))) (substring string 1 (string-length string))))
@ -272,7 +298,7 @@
(define-struct ms (who id? say)) (define-struct ms (who id? say))
;add-to-message: err string (list err) -> (list err) ;add-to-message: err string bool (list err) -> (list err)
(define (add-to-message msg name id? rest) (define (add-to-message msg name id? rest)
(let ([next (make-ms name id? msg)] (let ([next (make-ms name id? msg)]
[curr-len (length rest)]) [curr-len (length rest)])
@ -285,16 +311,18 @@
[(< (length rest) max-depth) (cons next rest)] [(< (length rest) max-depth) (cons next rest)]
[else (cons next (first-n (sub1 max-depth) rest))]))) [else (cons next (first-n (sub1 max-depth) rest))])))
;combine-message: err (list ms) -> err ;combine-message: (list ms) -> err
(define (combine-message end-msg messages) (define (collapse-message messages)
(let loop ([end-msg (ms-say (car messages))]
[messages (cdr messages)])
(cond (cond
[(null? messages) end-msg] [(null? messages) end-msg]
[else [else
(combine-message (loop
(make-err (string-append (err-msg (ms-say (car messages))) (make-err (string-append (err-msg (ms-say (car messages)))
(err-msg end-msg)) (err-msg end-msg))
(err-src end-msg)) (err-src end-msg))
(cdr messages))])) (cdr messages))])))
) )
) )