218 lines
12 KiB
Scheme
218 lines
12 KiB
Scheme
(module combinator-parser scheme/base
|
|
|
|
(require scheme/list
|
|
scheme/unit
|
|
parser-tools/lex)
|
|
(require "structs.scm" "parser-sigs.ss" "combinator.scm" "errors.scm")
|
|
|
|
(provide combinator-parser-tools@)
|
|
|
|
(define-unit main-parser@
|
|
(import error^ out^ error-format-parameters^ language-format-parameters^ ranking-parameters^)
|
|
(export parser^)
|
|
|
|
(define (sort-used reses)
|
|
(sort reses
|
|
(lambda (a b) (> (res-used a) (res-used b)))))
|
|
(define (sort-repeats repeats)
|
|
(sort repeats
|
|
(lambda (a b) (> (res-used (repeat-res-a a))
|
|
(res-used (repeat-res-a b))))))
|
|
|
|
(define (parser start)
|
|
(lambda (input file)
|
|
(let* ([first-src (and src? (pair? input)
|
|
(make-src-lst (position-token-start-pos (car input))
|
|
(position-token-end-pos (car input))))]
|
|
[result (if first-src (start input first-src) (start input))]
|
|
[out
|
|
(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))
|
|
(fail-type->message (res-possible-error result))]
|
|
[(and (res? result) (res-a result))
|
|
(make-err
|
|
(format "Found extraneous input after ~a, starting with ~a, at the end of ~a."
|
|
(res-msg result)
|
|
(input->output-name (car (res-rest result))) input-type)
|
|
(and src?
|
|
(make-src-lst (position-token-start-pos (car (res-rest result)))
|
|
(position-token-end-pos (car (res-rest result))))))]
|
|
[(res? result)
|
|
(fail-type->message (res-msg result))]
|
|
[(lazy-opts? result)
|
|
#;(printf "lazy-opts ~a\n" result)
|
|
(let* ([finished? (lambda (o)
|
|
(cond [(res? o)
|
|
(and (not (null? (res-a o)))
|
|
(null? (res-rest o)))]
|
|
[(repeat-res? o)
|
|
(eq? (repeat-res-stop o) 'out-of-input)]
|
|
[else #f]))]
|
|
[possible-errors
|
|
(lambda (matches)
|
|
(map (lambda (r)
|
|
(or (and (res? r) (res-possible-error r))
|
|
(and (repeat-res? r) (repeat-res-stop r))))
|
|
(filter (lambda (r)
|
|
(or (and (res? r) (res-possible-error r))
|
|
(and (repeat-res? r) (fail-type? (repeat-res-stop r)))))
|
|
matches)))]
|
|
[result-a
|
|
(lambda (res)
|
|
(cond
|
|
[(res? res) (res-a res)]
|
|
[(and (repeat-res? res)
|
|
(res? (repeat-res-a res)))
|
|
(res-a (repeat-res-a res))]
|
|
[else
|
|
(error 'parser-internal-errorcl (format "~a" res))]))])
|
|
(let loop ([matched (lazy-opts-matches result)])
|
|
(cond
|
|
[(and (pair? matched) (finished? (car matched))) (result-a (car matched))]
|
|
[(pair? matched) (loop (cdr matched))]
|
|
[(and matched (finished? matched)) (result-a matched)]
|
|
[(or (null? matched) matched) (loop (next-opt result))]
|
|
[else
|
|
(let ([p-errors (possible-errors (lazy-opts-matches result))])
|
|
(cond
|
|
[(pair? p-errors)
|
|
(let ([fails (cons (lazy-opts-errors result) p-errors)])
|
|
#;(printf "\nfails ~a\n\n" fails)
|
|
(fail-type->message
|
|
(make-options-fail (rank-choice (map fail-type-chance fails))
|
|
#f
|
|
(if (lazy-choice? result)
|
|
(lazy-choice-name result) "program")
|
|
(rank-choice (map fail-type-used fails))
|
|
(rank-choice (map fail-type-may-use fails))
|
|
fails)))]
|
|
[(null? p-errors)
|
|
(fail-type->message (lazy-opts-errors result))]))])))]
|
|
[(or (choice-res? result) (pair? result))
|
|
#;(printf "choice-res or pair? ~a\n" result)
|
|
(let* ([options (if (choice-res? result) (choice-res-matches result) result)]
|
|
[finished-options (filter (lambda (o)
|
|
(cond [(res? o)
|
|
(and (not (null? (res-a o)))
|
|
(null? (res-rest o)))]
|
|
[(repeat-res? o)
|
|
(eq? (repeat-res-stop o) 'out-of-input)]))
|
|
options)]
|
|
[possible-repeat-errors
|
|
(filter (lambda (r) (and (repeat-res? r)
|
|
(fail-type? (repeat-res-stop r))))
|
|
options)]
|
|
[possible-errors
|
|
(filter res-possible-error
|
|
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a))
|
|
options))])
|
|
#;(printf "length finished-options ~a\n" finished-options)
|
|
(cond
|
|
[(not (null? finished-options))
|
|
#;(printf "finished an option\n")
|
|
(let ([first-fo (car finished-options)])
|
|
(car (cond
|
|
[(res? first-fo) (res-a first-fo)]
|
|
[(and (repeat-res? first-fo)
|
|
(res? (repeat-res-a first-fo)))
|
|
(res-a (repeat-res-a first-fo))]
|
|
[else
|
|
(error 'parser-internal-errorcp
|
|
(format "~a" first-fo))])))]
|
|
#;[(not (null? possible-repeat-errors))
|
|
(printf "possible-repeat error\n")
|
|
(fail-type->message
|
|
(car (repeat-res-stop
|
|
(sort-repeats possible-repeat-errors))))]
|
|
[(and (choice-res? result) (fail-type? (choice-res-errors result)))
|
|
#;(printf "choice res and choice res errors \n")
|
|
(cond
|
|
[(and (null? possible-repeat-errors)
|
|
(null? possible-errors)) (fail-type->message (choice-res-errors result))]
|
|
[(or #;(not (null? possible-repeat-errors))
|
|
(not (null? possible-errors)))
|
|
(let ([fails (cons (choice-res-errors result)
|
|
(map res-possible-error possible-errors))])
|
|
(fail-type->message
|
|
(make-options-fail (rank-choice (map fail-type-chance fails))
|
|
#f
|
|
(choice-res-name result)
|
|
(rank-choice (map fail-type-used fails))
|
|
(rank-choice (map fail-type-may-use fails))
|
|
fails)))])]
|
|
[(not (null? possible-errors))
|
|
;(printf "choice or pair fail\n")
|
|
(fail-type->message
|
|
(res-possible-error (car (sort-used possible-errors))))]
|
|
[else
|
|
#;(printf "result ~a\n" result)
|
|
(let ([used-sort (sort-used options)])
|
|
(if (and (choice-res? result)
|
|
(choice-res-errors result))
|
|
(fail-type->message (choice-res-errors result))
|
|
(make-err
|
|
(format "Found additional content after ~a, beginning 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)))
|
|
;(printf "repeat-fail\n")
|
|
(fail-type->message (repeat-res-stop result))]
|
|
[else (error 'parser (format "Internal error: received unexpected input ~a"
|
|
result))])])
|
|
(cond
|
|
[(err? out)
|
|
(make-err (err-msg out)
|
|
(if (err-src out)
|
|
(list file
|
|
(first (err-src out))
|
|
(second (err-src out))
|
|
(third (err-src out))
|
|
(fourth (err-src out)))
|
|
(list file 1 0 1 0)))]
|
|
[else out]))))
|
|
)
|
|
|
|
#;(define-unit rank-defaults@
|
|
(import)
|
|
(export ranking-parameters^)
|
|
(define (rank-choice choices) (apply max choices))
|
|
(define-values
|
|
(rank-misspell rank-caps rank-class rank-wrong rank-end)
|
|
(values 4/5 9/10 2/5 1/5 2/5)))
|
|
|
|
(define-unit rank-defaults@
|
|
(import)
|
|
(export ranking-parameters^)
|
|
(define (rank-choice choices) (apply max choices))
|
|
(define-values
|
|
(rank-misspell rank-caps rank-class rank-wrong rank-end rank-repeat)
|
|
(values 16/71 18/71 8/71 4/71 8/71 17/71)))
|
|
|
|
|
|
(define-unit out-struct@
|
|
(import)
|
|
(export out^)
|
|
(define-struct err (msg src) #:mutable))
|
|
|
|
(define-compound-unit/infer combinator-parser@
|
|
(import error-format-parameters^ language-format-parameters^ language-dictionary^)
|
|
(export combinator-parser-forms^ parser^ out^)
|
|
(link out-struct@ main-parser@ rank-defaults@ error-formatting@ combinators@))
|
|
|
|
(define-unit/new-import-export combinator-parser-tools@
|
|
(import error-format-parameters^ language-format-parameters^ language-dictionary^)
|
|
(export combinator-parser^ err^)
|
|
((combinator-parser-forms^ parser^ out^) combinator-parser@ error-format-parameters^ language-format-parameters^
|
|
language-dictionary^))
|
|
|
|
)
|