diff --git a/collects/combinator-parser/private-combinator/combinator-parser.scm b/collects/combinator-parser/private-combinator/combinator-parser.scm index f8212da465..b6b410bad0 100644 --- a/collects/combinator-parser/private-combinator/combinator-parser.scm +++ b/collects/combinator-parser/private-combinator/combinator-parser.scm @@ -22,7 +22,7 @@ (cond [(and (res? result) (res-a result) (null? (res-rest result))) (car (res-a (!!! result)))] - [(and (res? result) (res-a result) (res-possible-error result)) + [(and (res? result) (res-a result) (!!! (res-possible-error result))) (fail-type->message (!!! (res-possible-error result)))] [(and (res? result) (res-a result)) (make-err @@ -51,17 +51,20 @@ (!!! (fail-type->message (res-possible-error (!!! (car (sort-used possible-errors))))))] [else + #;(printf "result ~a~n" result) (let ([used-sort (sort-used options)]) - #;(!!! (printf "~a~n" used-sort)) - (make-err - (format "Found additional content after ~a, begining with '~a'." - (!!! (res-msg (car used-sort))) - (input->output-name (!!! (car (res-rest (car used-sort)))))) - (and src? - (make-src-lst (position-token-start-pos - (!!! (car (res-rest (car used-sort))))) - (position-token-end-pos - (!!! (car (res-rest (car used-sort)))))))))]))] + (if (and (choice-res? result) + (choice-res-errors result)) + (!!! (fail-type->message (choice-res-errors result))) + (make-err + (format "Found additional content after ~a, begining with '~a'." + (!!! (res-msg (car used-sort))) + (input->output-name (!!! (car (res-rest (car used-sort)))))) + (and src? + (make-src-lst (position-token-start-pos + (!!! (car (res-rest (car used-sort))))) + (position-token-end-pos + (!!! (car (res-rest (car used-sort))))))))))]))] [(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop (!!! result)))) (res-a (repeat-res-a result))] [(and (repeat-res? result) (fail-type? (repeat-res-stop (!!! result)))) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm index f631d80efd..8ffd333d41 100644 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ b/collects/combinator-parser/private-combinator/combinator.scm @@ -192,6 +192,7 @@ (cond [(null? subs) (error 'end-of-subs)] [(null? next-preds) + #;(printf "seq-warker called: last case, ~a ~n" seq-name) (build-error (curr-pred input last-src) (previous? input) (previous? return-name) #f look-back used curr-id seen alts last-src)] @@ -203,7 +204,8 @@ (cond [(res? fst) (cond - [(res-a fst) (next-call fst fst (res-msg fst) (and id-spot? (res-id fst)) + [(res-a fst) (next-call fst fst (res-msg fst) + (and id-spot? (res-id fst)) (res-first-tok fst) alts)] [else #;(printf "error situation~n") @@ -291,99 +293,134 @@ (update-src-start src (position-token-start-pos tok)) src)]))) + ;build-options-fail: name (list-of fail-type) -> fail-type + (define (build-options-fail name fails) + (make-options-fail (rank-choice (map fail-type-chance fails)) + #f + name + (rank-choice (map fail-type-used fails)) + (rank-choice (map fail-type-may-use fails)) + fails)) + ;build-sequence-error: result boolean result string int [U #f string] [listof string] int int -> result (define (sequence-error-gen name len) - (lambda (old-res prev prev-name next-pred look-back used id seen alts last-src) - (cond - [(and (pair? old-res) (null? (cdr old-res))) (car old-res)] - [(repeat-res? old-res) - (let ([inner-res (repeat-res-a old-res)] - [stop (repeat-res-stop old-res)]) - (cond - [stop - (make-res (res-a inner-res) - (res-rest inner-res) - (res-msg inner-res) - (res-id inner-res) - (res-used inner-res) - (if (and (zero? (res-used inner-res)) - (choice-res? look-back) (choice-res-errors look-back) - (> (fail-type-chance (choice-res-errors look-back)) - (fail-type-chance stop))) - (choice-res-errors look-back) - stop) - (res-first-tok inner-res))] - [else inner-res]))] - [(or (and (res? old-res) (res-a old-res)) - (choice-res? old-res) - (pair? old-res)) old-res] - [else - ;There actually was an error - (fail-res (res-rest old-res) - (let*-values ([(fail) - (cond - [(and (repeat-res? look-back) - (fail-type? (repeat-res-stop look-back)) - (> (fail-type-chance (repeat-res-stop look-back)) - (fail-type-chance (res-msg old-res)))) - (repeat-res-stop look-back)] - [(and (choice-res? look-back) - (choice-res-errors look-back) - (> (fail-type-chance (choice-res-errors look-back)) - (fail-type-chance (res-msg old-res)))) - (choice-res-errors look-back)] - [else (res-msg old-res)])] - [(next-ok?) - (and (= (fail-type-may-use fail) 1) - (not (null? (res-rest old-res))) - next-pred - (next-pred (cdr (res-rest old-res))))] - [(next-used) - (if (and next-ok? (res? next-ok?) (res-a next-ok?)) - (res-used next-ok?) - 0)] - [(kind expected found) (get-fail-info fail)] - [(new-src) (update-src kind - (fail-type-src fail) - last-src - (res-first-tok old-res))] - [(seen-len) (length seen)] - [(updated-len) (+ (- used seen-len) len)]) - #;(printf "sequence ~a failed.~n seen ~a~n" name (reverse seen)) - #;(when (repeat-res? look-back) - (printf "look-back ~a : ~a vs ~a : ~a > ~a~n" - (repeat-res-stop look-back) - (and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back))) - (fail-type-name (res-msg old-res)) - (and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back))) - (fail-type-chance (res-msg old-res)))) - #;(when (choice-res? look-back) - (printf "look-back choice: ~a vs ~a : ~a > ~a~n" - (choice-res-name look-back) - (fail-type-name (res-msg old-res)) - (when (choice-res-errors look-back) - (fail-type-chance (choice-res-errors look-back))) - (fail-type-chance (res-msg old-res)))) - #;(when (pair? look-back) - (printf "look-back is a pair~n")) - #;(when (res? look-back) - (printf "lookbac is a res~n")) - #;(printf "old-probability ~a new probability ~a~n" - (cond - [(= 0 used) (fail-type-chance fail)] - [else (+ (* (fail-type-chance fail) (/ 1 updated-len)) - (/ used updated-len))]) - (compute-chance len seen-len used alts (fail-type-chance fail))) - (make-sequence-fail - (cond - [(= 0 used) (fail-type-chance fail)] - [else (compute-chance len seen-len used alts (fail-type-chance fail))]) - (fail-type-src fail) - name used - (+ used (fail-type-may-use fail) next-used) - id kind (reverse seen) expected found - (and (res? prev) (res-a prev) (res-msg prev)) - prev-name)))]))) + (letrec ([repeat->res + (lambda (rpt back) + (cond + [(pair? rpt) (map (lambda (r) (repeat->res r back)) rpt)] + [(repeat-res? rpt) + (let ([inn (repeat-res-a rpt)] + [stop (repeat-res-stop rpt)]) + (cond + [stop + (make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn) + (if (and (zero? (res-used inn)) + (choice-res? back) (choice-res-errors back) + (or (not (fail-type? stop)) + (> (fail-type-chance (choice-res-errors back)) + (fail-type-chance stop)))) + (choice-res-errors back) + stop) + (res-first-tok inn))] + [else inn]))] + [else rpt]))]) + (lambda (old-res prev prev-name next-pred look-back used id seen alts last-src) + (cond + #;[(and (pair? old-res) (null? (cdr old-res))) (car old-res)] + [(or (and (res? old-res) (res-a old-res)) (choice-res? old-res)) + old-res] + [(repeat-res? old-res) + #;(!!! (printf "finished on repeat-res for ~a res ~a~n" name old-res)) + (repeat->res old-res look-back)] + [(pair? old-res) + #;(!!! (printf "finished on pairs of res ~a~n" old-res)) + (map (lambda (r) (repeat->res r look-back)) old-res)] + [else + ;There actually was an error + (fail-res (res-rest old-res) + (let*-values ([(fail) (res-msg old-res)] + [(possible-fail) + (cond + [(and (repeat-res? look-back) + (fail-type? (repeat-res-stop look-back)) + (> (fail-type-chance (repeat-res-stop look-back)) + (fail-type-chance fail))) + (repeat-res-stop look-back)] + [(and (choice-res? look-back) + (choice-res-errors look-back) + (> (fail-type-chance (choice-res-errors look-back)) + (fail-type-chance fail))) + (choice-res-errors look-back)] + [(and (res? look-back) + (fail-type? (res-possible-error look-back)) + (> (fail-type-chance (res-possible-error look-back)) + (fail-type-chance fail))) + (res-possible-error look-back)] + [else #f])] + [(next-ok?) + (and (= (fail-type-may-use fail) 1) + (not (null? (res-rest old-res))) + next-pred + (next-pred (cdr (res-rest old-res))))] + [(next-used) + (if (and next-ok? (res? next-ok?) (res-a next-ok?)) + (res-used next-ok?) + 0)] + [(kind expected found) (get-fail-info fail)] + [(new-src) (update-src kind + (fail-type-src fail) + last-src + (res-first-tok old-res))] + [(seen-len) (length seen)] + [(updated-len) (+ (- used seen-len) len)]) + #;(printf "sequence ~a failed.~n seen ~a~n" name (reverse seen)) + #;(when (repeat-res? look-back) + (printf "look-back ~a : ~a vs ~a : ~a > ~a~n" + (repeat-res-stop look-back) + (and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back))) + (fail-type-name (res-msg old-res)) + (and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back))) + (fail-type-chance (res-msg old-res)))) + #;(when (choice-res? look-back) + (printf "look-back choice: ~a vs ~a : ~a > ~a~n" + (choice-res-name look-back) + (fail-type-name (res-msg old-res)) + (when (choice-res-errors look-back) + (fail-type-chance (choice-res-errors look-back))) + (fail-type-chance (res-msg old-res)))) + #;(when (pair? look-back) + (printf "look-back is a pair~n")) + #;(when (res? look-back) + (printf "lookbac is a res~n")) + #;(printf "old-probability ~a new probability ~a~n" + (cond + [(= 0 used) (fail-type-chance fail)] + [else (+ (* (fail-type-chance fail) (/ 1 updated-len)) + (/ used updated-len))]) + (compute-chance len seen-len used alts (fail-type-chance fail))) + (let* ([seq-fail-maker + (lambda (fail) + (make-sequence-fail + (cond + [(= 0 used) (fail-type-chance fail)] + [else (compute-chance len seen-len used alts (fail-type-chance fail))]) + (fail-type-src fail) + name used + (+ used (fail-type-may-use fail) next-used) + id kind (reverse seen) expected found + (and (res? prev) (res-a prev) (res-msg prev)) + prev-name))] + [seq-fail (seq-fail-maker fail)] + [pos-fail (and possible-fail (seq-fail-maker fail))] + [opt-fails (list seq-fail pos-fail)]) + (if pos-fail + (make-options-fail (rank-choice (map fail-type-chance opt-fails)) + #f + name + (rank-choice (map fail-type-used opt-fails)) + (rank-choice (map fail-type-may-use opt-fails)) + opt-fails) + seq-fail))))])))) (define (compute-chance expected-length seen-length used-toks num-alts sub-chance) (let* ([revised-expectation (+ (- used-toks seen-length) expected-length)] @@ -456,6 +493,9 @@ (process-rest (repeat-res-a this-res) (res-rest (repeat-res-a this-res)))] [(or (choice-res? this-res) (pair? this-res)) + #;(printf "repeat call, choice-res ~a~n" + (and (choice-res? this-res) + (length (choice-res-matches this-res)))) (map (lambda (match) (process-rest match (loop (res-rest match)))) (if (choice-res? this-res) (choice-res-matches this-res) @@ -520,7 +560,7 @@ [(repeat-res? (car subs)) (correct-list (cons (repeat-res-a (car subs)) (cdr subs)))] [(pair? (car subs)) - (append (correct-list (car subs)) (correct-list (cdr subs)))] + (apply append (cons (correct-list (car subs)) (correct-list (cdr subs))))] [else (correct-list (cdr subs))])] [(null? subs) null] [else (printf "subs~a~n" subs) (error 'stop5)])) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm index 7e84b5438f..a258b14896 100644 --- a/collects/combinator-parser/private-combinator/errors.scm +++ b/collects/combinator-parser/private-combinator/errors.scm @@ -142,8 +142,8 @@ [(and (choice-fail-ended? fail-type) (> (length winners) 1)) (combine-message - (msg (format "Expected a ~a, possible forms are ~a.") - (nice-list (first-n max-choice-depth no-dup-names))) + (msg (format "Expected a ~a, possible forms are ~a." name + (nice-list (first-n max-choice-depth no-dup-names)))) message-to-date)] [(and (<= (choice-fail-options fail-type) max-choice-depth) (> (length no-dup-names) 1) diff --git a/collects/combinator-parser/private-combinator/structs.scm b/collects/combinator-parser/private-combinator/structs.scm index ac147ef236..95662acbb9 100644 --- a/collects/combinator-parser/private-combinator/structs.scm +++ b/collects/combinator-parser/private-combinator/structs.scm @@ -68,7 +68,7 @@ ;(make-res (U #f (listof 'b)) (listof 'a) (U string fail-type) (U string 'a) int) [U #f fail-type] token (define-struct res (a rest msg id used possible-error first-tok) (make-inspector)) ;make-choice-res string (listof res fail-type) - (define-struct choice-res (name matches errors)) + (define-struct choice-res (name matches errors) (make-inspector)) ;(make-repeat-res answer (U symbol fail-type)) (define-struct repeat-res (a stop) (make-inspector)) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index e0a0ddb694..b99d94e929 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -558,7 +558,7 @@ (let ([m&e (sequence ((repeat modifier) interface (^ IDENTIFIER) extends O_BRACE body C_BRACE) id "interface definition")] [m (sequence ((repeat modifier) interface (^ IDENTIFIER) O_BRACE body C_BRACE) id "interface definition")] - [e (sequence (interface (^ IDENTIFIER) extends O_BRACE body C_BRACE id) "interface definition")] + [e (sequence (interface (^ IDENTIFIER) extends O_BRACE body C_BRACE) id "interface definition")] [always (sequence (interface (^ IDENTIFIER) O_BRACE body C_BRACE) id "interface definition")]) (choice (cond [(and modifier extends) (list m&e m e always)] @@ -684,7 +684,8 @@ (repeat-greedy (class-body (list field method constructor))))) (define program - (make-program #f (repeat-greedy import-dec) (repeat-greedy (top-member (list class interface))))) + (make-program #f (repeat-greedy import-dec) + (repeat-greedy (top-member (list class interface))))) ) (define-unit intermediate-grammar@ @@ -763,7 +764,8 @@ (define program - (make-program #f (repeat-greedy import-dec) (repeat-greedy (top-member (list class interface))))) + (make-program #f (repeat-greedy import-dec) + (repeat-greedy (choose (class interface) "class or interface")))) )