348 lines
17 KiB
Scheme
348 lines
17 KiB
Scheme
(module errors mzscheme
|
|
|
|
(require "structs.scm" "parser-sigs.ss")
|
|
|
|
(require (lib "force.ss" "lazy")
|
|
(lib "etc.ss")
|
|
(lib "unit.ss")
|
|
(lib "list.ss"))
|
|
|
|
(provide (all-defined))
|
|
|
|
(define-unit error-formatting@
|
|
(import error-format-parameters^ language-format-parameters^ out^)
|
|
(export (rename error^ (public-fail-type->message fail-type->message)))
|
|
|
|
;public-fail-type->message : fail-type -> err
|
|
(define (public-fail-type->message fail)
|
|
(fail-type->message fail null))
|
|
|
|
;fail-type->message: fail-type (listof err) -> err
|
|
(define (fail-type->message fail-type message-to-date)
|
|
(let* ([fail-type (!!!-fail fail-type)]
|
|
[input->output-name (!!! input->output-name)]
|
|
[name (fail-type-name fail-type)]
|
|
[a (a/an name)]
|
|
[msg (lambda (m) (make-err m (fail-type-src fail-type)))])
|
|
#;(printf "fail-type->message ~a~n" fail-type)
|
|
(cond
|
|
[(terminal-fail? fail-type)
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg
|
|
(case (terminal-fail-kind fail-type)
|
|
[(end) (format "Expected to find ~a ~a, but ~a ended prematurely."
|
|
a name input-type)]
|
|
[(wrong) (format "Expected to find ~a ~a, but instead found ~a."
|
|
a name (input->output-name (terminal-fail-found fail-type)))]
|
|
[(misscase) (format "Expected to find ~a ~a, found ~a which may be miscapitalized."
|
|
a name (input->output-name (terminal-fail-found fail-type)))]
|
|
[(misspell) (format "Expected to find ~a ~a, found ~a which may be misspelled."
|
|
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."
|
|
(input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
|
|
name #f message-to-date))]
|
|
[(sequence-fail? fail-type)
|
|
#;(printf "sequence-fail case: kind is ~a~n" (sequence-fail-kind fail-type))
|
|
(let* ([curr-id (sequence-fail-id fail-type)]
|
|
[id-name
|
|
(if curr-id (string-append name " " (sequence-fail-id fail-type)) name)]
|
|
[expected (sequence-fail-expected fail-type)]
|
|
[a2 (a/an expected)]
|
|
[show-sequence (sequence-fail-correct fail-type)])
|
|
(case (sequence-fail-kind fail-type)
|
|
[(end)
|
|
(collapse-message
|
|
(add-to-message
|
|
(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))
|
|
name curr-id message-to-date))]
|
|
[(wrong)
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg
|
|
(cond
|
|
[(sequence-fail-repeat? fail-type)
|
|
(format "Found a repitition of ~a; the required number are present. Expected ~a ~a next."
|
|
(sequence-fail-last-seen fail-type) a2 expected)]
|
|
[(null? show-sequence)
|
|
(format "Expected ~a ~a to begin this ~a, instead found ~a."
|
|
a2 expected id-name (input->output-name (sequence-fail-found fail-type)))]
|
|
[else
|
|
(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))
|
|
(format-seen show-sequence))]))
|
|
name curr-id message-to-date))]
|
|
[(misscase)
|
|
(collapse-message
|
|
(add-to-message
|
|
(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))))
|
|
name curr-id message-to-date))]
|
|
[(misspell)
|
|
(collapse-message
|
|
(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))))
|
|
name curr-id message-to-date))]
|
|
[(missclass)
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a."
|
|
(input->output-name (sequence-fail-found fail-type)) a2 expected class-type a2 expected))
|
|
name curr-id message-to-date))]
|
|
[(sub-seq choice)
|
|
(fail-type->message (sequence-fail-found fail-type)
|
|
(add-to-message (msg (format "An error occured in ~a.~n" id-name))
|
|
name (sequence-fail-id fail-type) message-to-date))]
|
|
[(options)
|
|
(let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type))
|
|
(lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))])
|
|
(if (null? show-sequence)
|
|
(fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts)
|
|
(add-to-message (msg (format "This ~a did not begin as expected." id-name))
|
|
name (sequence-fail-id fail-type) message-to-date))
|
|
(fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts)
|
|
(add-to-message
|
|
(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))))
|
|
name (sequence-fail-id fail-type) message-to-date))))]))]
|
|
[(options-fail? fail-type)
|
|
#;(printf "selecting for options on ~a~n" name)
|
|
(let* ([winners (select-errors (options-fail-opts fail-type))]
|
|
[top-names (map fail-type-name winners)]
|
|
[non-dup-tops (remove-dups top-names name)]
|
|
[top-name (car top-names)])
|
|
(cond
|
|
[(and (> (length winners) 1)
|
|
(> (length non-dup-tops) 1)
|
|
(> (length winners) max-choice-depth))
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg (format "An error occurred in this ~a. Program resembles these: ~a.~n"
|
|
name (nice-list non-dup-tops)))
|
|
name #f message-to-date))]
|
|
[(and (> (length winners) 1)
|
|
(<= (length winners) max-choice-depth))
|
|
(let ([messages (map (lambda (f) (fail-type->message f null)) winners)])
|
|
(cond
|
|
[(identical-messages? messages)
|
|
(collapse-message
|
|
(add-to-message (car messages) name #f message-to-date))]
|
|
[else
|
|
(collapse-message
|
|
(add-to-message
|
|
(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
|
|
(fail-type->message
|
|
(car winners)
|
|
(add-to-message
|
|
(msg
|
|
(format "There is an error in this ~a~a.~n"
|
|
name
|
|
(if (equal? top-name name) ""
|
|
(format ", program resembles ~a ~a" (a/an top-name) top-name))))
|
|
name #f message-to-date))]))]
|
|
[(choice-fail? fail-type)
|
|
#;(printf "selecting for ~a~n message-to-date ~a~n" name message-to-date)
|
|
(let* ([winners (select-errors (choice-fail-messages fail-type))]
|
|
[top-names (map fail-type-name winners)]
|
|
[top-name (car top-names)]
|
|
[no-dup-names (remove-dups (choice-fail-names fail-type) name)])
|
|
(cond
|
|
[(and (choice-fail-ended? fail-type)
|
|
(> (length winners) 1))
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg (format "Expected a ~a, possible options include ~a." name
|
|
(nice-list (first-n max-choice-depth no-dup-names))))
|
|
name #f message-to-date))]
|
|
[(and (<= (choice-fail-options fail-type) max-choice-depth)
|
|
(> (length no-dup-names) 1)
|
|
(> (length winners) 1)
|
|
(equal? top-names no-dup-names))
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg (format "An error occured in this ~a; expected ~a instead."
|
|
name (nice-list no-dup-names)))
|
|
name #f message-to-date))]
|
|
[(and (<= (choice-fail-options fail-type) max-choice-depth)
|
|
(> (length no-dup-names) 1)
|
|
(> (length winners) 1))
|
|
(let ([messages (map (lambda (f) (fail-type->message f null)) winners)])
|
|
(cond
|
|
[(identical-messages? messages)
|
|
(collapse-message
|
|
(add-to-message (car messages) #f #f
|
|
(add-to-message
|
|
(msg (format "An error occured in this ~a, expected ~a instead."
|
|
name (nice-list no-dup-names))
|
|
name #f message-to-date))))]
|
|
[else
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg (format "An error occured in this ~a; expected ~a instead. 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)
|
|
(> (length winners) 1))
|
|
(collapse-message
|
|
(add-to-message
|
|
(msg (format "An error occured in this ~a. Possible options include ~a.~n"
|
|
name (nice-list
|
|
(first-n max-choice-depth no-dup-names))))
|
|
name #f message-to-date))]
|
|
[else
|
|
(fail-type->message
|
|
(car winners)
|
|
(add-to-message
|
|
(msg (format "An error occured in this ~a~a.~a~n"
|
|
name
|
|
(if (equal? name top-name) "" (format ", it is possible you intended ~a ~a here"
|
|
(a/an top-name) top-name))
|
|
(if show-options " To see all options click here." "")))
|
|
name #f message-to-date))]))])))
|
|
|
|
(define (chance-used a) (* (fail-type-chance a) (fail-type-used a)))
|
|
(define (chance-may-use a) (* (fail-type-chance a) (fail-type-may-use a)))
|
|
(define (chance a) (fail-type-chance a))
|
|
(define (composite a)
|
|
(/ (+ (chance-used a) (chance-may-use a) (chance a)) 3))
|
|
|
|
(define (narrow-opts rank options)
|
|
(get-ties (sort options (lambda (a b) (> (rank a) (rank b)))) rank))
|
|
|
|
(define (select-errors opts-list)
|
|
(let* ([composite-winners
|
|
(narrow-opts composite (!!list opts-list))]
|
|
|
|
[chance-used-winners
|
|
(narrow-opts chance-used composite-winners)]
|
|
|
|
[chance-may-winners
|
|
(narrow-opts chance-may-use chance-used-winners)]
|
|
|
|
[winners (narrow-opts chance chance-may-winners)])
|
|
#;(printf "all options: ~a~n" (!!list opts-list))
|
|
#;(printf "~a ~a ~a ~a ~n"
|
|
(map fail-type-name (map !!! (!!list opts-list)))
|
|
(map !!! (map fail-type-chance (!!list opts-list)))
|
|
(map !!! (map fail-type-used (!!list opts-list)))
|
|
(map !!! (map fail-type-may-use (!!list opts-list))))
|
|
#;(printf "composite round: ~a ~a ~n"
|
|
(map fail-type-name (map !!! composite-winners))
|
|
(map composite (map !!! composite-winners)))
|
|
#;(printf "final sorting: ~a~n" (map fail-type-name (map !!! winners)))
|
|
winners))
|
|
|
|
(define (first-n n lst)
|
|
(if (<= (length lst) n)
|
|
lst
|
|
(let loop ([count 0] [l lst])
|
|
(cond
|
|
[(>= count n) null]
|
|
[else (cons (car l) (loop (add1 count) (cdr l)))]))))
|
|
|
|
(define (get-ties lst evaluate)
|
|
(if (> (length lst) 1)
|
|
(letrec ([getter
|
|
(lambda (sub)
|
|
(cond
|
|
[(null? sub) null]
|
|
[(>= (- (evaluate (car lst)) (evaluate (car sub))) .0001) null]
|
|
[else (cons (car sub) (getter (cdr sub)))]))])
|
|
(cons (car lst) (getter (cdr lst))))
|
|
lst))
|
|
|
|
(define (a/an next-string)
|
|
(if (string? next-string)
|
|
(if (member (substring next-string 0 1) `("a" "e" "i" "o" "u"))
|
|
"an" "a")
|
|
"a"))
|
|
|
|
(define (format-seen l)
|
|
(if (null? l)
|
|
""
|
|
(string-append "'"
|
|
(car l)
|
|
(apply string-append
|
|
(map (lambda (i) (string-append " " i)) (cdr l)))
|
|
"'")))
|
|
|
|
(define (nice-list l)
|
|
(letrec ([formatter
|
|
(lambda (l)
|
|
(cond
|
|
[(null? l) ""]
|
|
[(null? (cdr l)) (string-append "or " (car l))]
|
|
[else (string-append (car l) ", " (formatter (cdr l)))]))])
|
|
(cond
|
|
[(null? l) (error 'internal-error "nice-list in combinator-parser/errors.scm recieved null list")]
|
|
[(null? (cdr l)) (car l)]
|
|
[(null? (cddr l)) (string-append (car l) " or " (cadr 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)
|
|
(string-append (string-downcase (substring string 0 1))
|
|
(substring string 1 (string-length string))))
|
|
|
|
(define (identical-messages? msgs)
|
|
(andmap (lambda (err) (equal? (err-msg (car msgs))
|
|
(err-msg err)))
|
|
(cdr msgs)))
|
|
|
|
(define (remove-dups l n)
|
|
(cond
|
|
[(null? l) null]
|
|
[(equal? (car l) n)
|
|
(remove-dups (cdr l) n)]
|
|
[(member (car l) (cdr l))
|
|
(remove-dups (cdr l) n)]
|
|
[else (cons (car l) (remove-dups (cdr l) n))]))
|
|
|
|
(define-struct ms (who id? say))
|
|
|
|
;add-to-message: err string bool (list err) -> (list err)
|
|
(define (add-to-message msg name id? rest)
|
|
(let ([next (make-ms name id? msg)]
|
|
[curr-len (length rest)])
|
|
(cond
|
|
[(null? rest) (list next)]
|
|
[(equal? (ms-who (car rest)) name) (cons next (cdr rest))]
|
|
[(and id? (ms-id? (car rest)) (< curr-len max-depth)) (cons next rest)]
|
|
[(and id? (ms-id? (car rest))) (cons next (first-n (sub1 max-depth) rest))]
|
|
[id? (add-to-message msg name id? (cdr rest))]
|
|
[(< (length rest) max-depth) (cons next rest)]
|
|
[else (cons next (first-n (sub1 max-depth) rest))])))
|
|
|
|
;combine-message: (list ms) -> err
|
|
(define (collapse-message messages)
|
|
(let loop ([end-msg (ms-say (car messages))]
|
|
[messages (cdr messages)])
|
|
(cond
|
|
[(null? messages) end-msg]
|
|
[else
|
|
(loop
|
|
(make-err (string-append (err-msg (ms-say (car messages)))
|
|
(err-msg end-msg))
|
|
(err-src end-msg))
|
|
(cdr messages))])))
|
|
|
|
)
|
|
)
|