Fixing bugs in parsing selection, and in indenting
svn: r6996
This commit is contained in:
Kathy Gray
parent
92f1e3fed2
commit
94a30c2e14
|
|
@ -53,15 +53,19 @@
|
|||
|
||||
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
|
||||
#;(!!! (printf "terminal ~a~n" name))
|
||||
#;(!!! (printf "input ~a~n" (cons? input)))
|
||||
#;(!!! (if (eq? input return-name)
|
||||
(printf "dummy given~n")
|
||||
(let ([token (!!! ((!!! position-token-token) (!!! (car input))))])
|
||||
(!!! (printf "Look at token ~a~n" token))
|
||||
(!!! (printf "calling token-name: ~a~n" ((!!! token-name) token)))
|
||||
(!!! (printf "calling pred: ~a~n" (pred token)))
|
||||
(!!! (printf "called pred~n"))
|
||||
(!!! (printf "car of input ~a~n" (position-token-token (car input)))))))
|
||||
#;(!!! (printf "input ~a~n" (pair? input)))
|
||||
#;(!!! (printf "input ~a~n" (null? input)))
|
||||
#;(!!! (cond
|
||||
[(eq? input return-name)
|
||||
(printf "dummy given~n")]
|
||||
[(null? input) (printf "null given~n")]
|
||||
[else
|
||||
(let ([token (!!! ((!!! position-token-token) (!!! (car input))))])
|
||||
#;(!!! (printf "Look at token ~a~n" token))
|
||||
#;(!!! (printf "calling token-name: ~a~n" ((!!! token-name) token)))
|
||||
#;(!!! (printf "calling pred: ~a~n" (pred token)))
|
||||
#;(!!! (printf "called pred~n"))
|
||||
#;(!!! (printf "car of input ~a~n" (position-token-token (car input)))))]))
|
||||
(cond
|
||||
[(eq? input return-name) name]
|
||||
[(null? input)
|
||||
|
|
@ -104,7 +108,8 @@
|
|||
(lambda (r)
|
||||
(cond
|
||||
[(res? r)
|
||||
(make-res (list (build (res-a r))) (res-rest r)
|
||||
(make-res (list (build (res-a r)))
|
||||
(res-rest r)
|
||||
name (res-id r) (res-used r)
|
||||
(res-possible-error r)
|
||||
(res-first-tok r))]
|
||||
|
|
@ -115,7 +120,7 @@
|
|||
(res-used (repeat-res-a r))
|
||||
(repeat-res-stop r)
|
||||
(res-first-tok (repeat-res-a r)))]
|
||||
[else (!!! (printf "~a~n" r)) (error 'stop1)]))]
|
||||
[else (error 'parser-internal-error1 r)]))]
|
||||
[my-error (sequence-error-gen name sequence-length)]
|
||||
[my-walker (seq-walker id-position name my-error)])
|
||||
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
|
||||
|
|
@ -134,6 +139,7 @@
|
|||
[else pre-build-ans])])
|
||||
(hash-table-put! memo-table input ans)
|
||||
#;(!!! (printf "sequence ~a returning ~n" name))
|
||||
#;(!!! (printf "answer is ~a ~n" ans))
|
||||
ans)])))))
|
||||
|
||||
;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result
|
||||
|
|
@ -151,7 +157,7 @@
|
|||
(or id (res-id (repeat-res-a rst)))
|
||||
(+ used (res-used (repeat-res-a rst)))
|
||||
(repeat-res-stop rst) tok)]
|
||||
[else (printf "~a~n" rst) (error 'stop2)]
|
||||
[else (error 'parser-internal-error2 rst)]
|
||||
))]
|
||||
[walker
|
||||
(lambda (subs input previous? look-back curr-id seen used alts last-src)
|
||||
|
|
@ -180,6 +186,8 @@
|
|||
[(choice-res? rsts)
|
||||
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
|
||||
(correct-list (choice-res-matches rsts)))]
|
||||
[(repeat-res? rsts)
|
||||
(next-res old-answer new-id old-used tok rsts)]
|
||||
[else (printf "~a~n" rsts) (error 'here2)])))])
|
||||
(cond
|
||||
[(null? next-preds)
|
||||
|
|
@ -288,12 +296,23 @@
|
|||
(cond
|
||||
[(and (pair? old-res) (null? (cdr old-res))) (car old-res)]
|
||||
[(repeat-res? old-res)
|
||||
(cond
|
||||
[(fail-type? (repeat-res-stop old-res))
|
||||
(let ([res (repeat-res-a old-res)])
|
||||
(make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res)
|
||||
(repeat-res-stop old-res) (res-first-tok res)))]
|
||||
[else (repeat-res-a 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]
|
||||
|
|
@ -307,6 +326,11 @@
|
|||
(> (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)
|
||||
|
|
@ -331,6 +355,17 @@
|
|||
(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)]
|
||||
|
|
@ -441,30 +476,33 @@
|
|||
[(hash-table-get memo-table input #f) (hash-table-get memo-table input)]
|
||||
[(eq? input return-name) name]
|
||||
[else
|
||||
(let* ([options (map (lambda (term) (term input last-src sub-opts)) opt-list)]
|
||||
#;[a (!!! (printf "choice-options ~a ~n ~a ~n~n~n" choice-names options))]
|
||||
[fails (map (lambda (x) (if (res? x) (res-msg x) (error 'here-non-res)))
|
||||
(let*-values
|
||||
([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)]
|
||||
#;[a (!!! (printf "choice-options ~a ~n ~a ~n~n~n" choice-names options))]
|
||||
[(fails) (map (lambda (x) (if (res? x) (res-msg x) (error 'here-non-res)))
|
||||
options)]
|
||||
[corrects (correct-list options)]
|
||||
[ans
|
||||
(cond
|
||||
[(null? corrects)
|
||||
(fail-res input
|
||||
(make-choice-fail (rank-choice (map fail-type-chance fails))
|
||||
(if (or (null? input)
|
||||
(not (position-token? (car input))))
|
||||
last-src
|
||||
(update-src-end
|
||||
last-src
|
||||
(position-token-end-pos (car input))))
|
||||
name
|
||||
(rank-choice (map fail-type-used fails))
|
||||
(rank-choice (map fail-type-may-use fails))
|
||||
num-choices choice-names
|
||||
(null? input)
|
||||
fails))]
|
||||
[(null? (cdr corrects)) (car corrects)]
|
||||
[else (make-choice-res name corrects)])])
|
||||
[(corrects errors) (split-list options)]
|
||||
[(fail-builder)
|
||||
(lambda (fails)
|
||||
(if (null? fails)
|
||||
#f
|
||||
(make-choice-fail (rank-choice (map fail-type-chance fails))
|
||||
(if (or (null? input)
|
||||
(not (position-token? (car input))))
|
||||
last-src
|
||||
(update-src-end
|
||||
last-src
|
||||
(position-token-end-pos (car input))))
|
||||
name
|
||||
(rank-choice (map fail-type-used fails))
|
||||
(rank-choice (map fail-type-may-use fails))
|
||||
num-choices choice-names
|
||||
(null? input)
|
||||
fails)))]
|
||||
[(ans)
|
||||
(cond
|
||||
[(null? corrects) (fail-res input (fail-builder fails))]
|
||||
[else (make-choice-res name corrects (fail-builder errors))])])
|
||||
#;(!!! (printf "choice ~a is returning ~a options were ~a ~n" name ans choice-names))
|
||||
(hash-table-put! memo-table input ans) ans)])))))
|
||||
|
||||
|
|
@ -485,6 +523,31 @@
|
|||
[(null? subs) null]
|
||||
[else (printf "subs~a~n" subs) (error 'stop5)]))
|
||||
|
||||
(define (split-list subs)
|
||||
(let loop ([in subs] [correct null] [incorrect null])
|
||||
(cond
|
||||
[(pair? in)
|
||||
(cond
|
||||
[(and (res? (car in)) (res-a (car in)))
|
||||
(loop (cdr in) (cons (car in) correct) incorrect)]
|
||||
[(choice-res? (car in))
|
||||
(loop (cdr in)
|
||||
(append (choice-res-matches (car in)) correct)
|
||||
(if (choice-res-errors (car in))
|
||||
(append (choice-fail-messages (choice-res-errors (car in))) incorrect)
|
||||
incorrect))]
|
||||
[(repeat-res? (car in))
|
||||
(loop (cdr in)
|
||||
(cons (repeat-res-a (car in)) correct)
|
||||
incorrect)]
|
||||
[(pair? (car in))
|
||||
(loop (append (car in) (cdr in)) correct incorrect)]
|
||||
[(res? (car in))
|
||||
(loop (cdr in) correct (cons (res-msg (car in)) incorrect))]
|
||||
[else (error 'split-list (car in))])]
|
||||
[(null? in)
|
||||
(values correct incorrect)])))
|
||||
|
||||
(define (update-src-start src new-start)
|
||||
(list (position-line new-start)
|
||||
(position-col new-start)
|
||||
|
|
@ -494,6 +557,7 @@
|
|||
(fourth src))))
|
||||
|
||||
(define (update-src-end src new-end)
|
||||
(when (null? src) (error 'update-src-end))
|
||||
(list (max (first src) 1)
|
||||
(second src)
|
||||
(max (third src) 1)
|
||||
|
|
@ -503,7 +567,7 @@
|
|||
(letrec ([name (string-append "any number of "(op return-name))]
|
||||
[r* (choice (list op
|
||||
(seq (list op r*)
|
||||
(lambda (list-args) (cons (car list-args) (cadr list-args)))
|
||||
(lambda (list-args) list-args #;(cons (car list-args) (cadr list-args)))
|
||||
name)
|
||||
(seq null (lambda (x) null) return-name))
|
||||
name)])
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@
|
|||
(input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
|
||||
message-to-date)]
|
||||
[(sequence-fail? fail-type)
|
||||
#;(printf "sequence-fail case: kind is ~a~n" (sequence-fail-kind fail-type))
|
||||
(let* ([id-name
|
||||
(if (sequence-fail-id fail-type)
|
||||
(string-append name " " (sequence-fail-id fail-type)) name)]
|
||||
|
|
@ -91,14 +92,19 @@
|
|||
[(options)
|
||||
(let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type))
|
||||
(lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))])
|
||||
(fail-type->message (car sorted-opts)
|
||||
(add-to-message
|
||||
(msg (format "There is an error in this ~a after ~a, it is likely you intended 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)))]))]
|
||||
(if (null? show-sequence)
|
||||
(fail-type->message (car sorted-opts)
|
||||
(add-to-message (msg (format "This ~a did not start as expected." id-name))
|
||||
name (sequence-fail-id fail-type) message-to-date))
|
||||
|
||||
(fail-type->message (car sorted-opts)
|
||||
(add-to-message
|
||||
(msg (format "There is an error in this ~a after ~a, it is likely you intended 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))]
|
||||
(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)])
|
||||
|
|
|
|||
|
|
@ -67,8 +67,8 @@
|
|||
|
||||
;(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)
|
||||
(define-struct choice-res (name matches))
|
||||
;make-choice-res string (listof res fail-type)
|
||||
(define-struct choice-res (name matches errors))
|
||||
;(make-repeat-res answer (U symbol fail-type))
|
||||
(define-struct repeat-res (a stop) (make-inspector))
|
||||
|
||||
|
|
|
|||
|
|
@ -411,8 +411,8 @@
|
|||
|
||||
(define checks
|
||||
(choose
|
||||
((sequence (check (eta expression) expect (eta expression)) id)
|
||||
(sequence (check (eta expression) expect (eta expression) within (eta expression)) id))
|
||||
((sequence (check (eta expression) expect (eta expression) within (eta expression)) id)
|
||||
(sequence (check (eta expression) expect (eta expression)) id))
|
||||
"check expression"))
|
||||
|
||||
)
|
||||
|
|
@ -652,13 +652,13 @@
|
|||
(sequence (O_PAREN (eta expression) C_PAREN) id)
|
||||
(sequence (! (eta expression)) id "conditional expression")
|
||||
(sequence (MINUS (eta expression)) id "negation expression")
|
||||
checks) "expression"))
|
||||
checks) "expression -unique base"))
|
||||
|
||||
(define unique-end
|
||||
(choose (field-access-end
|
||||
method-call-end
|
||||
(binary-expression-end (bin-ops (list math-ops compare-ops bool-ops))))
|
||||
"expression"))
|
||||
"expression -unique end"))
|
||||
|
||||
(define expression
|
||||
(sequence (unique-base (repeat-greedy unique-end)) id "expression"))
|
||||
|
|
|
|||
|
|
@ -138,7 +138,8 @@
|
|||
[last-line-indent (sub1 (- last-line-start previous-line))]
|
||||
[old-open (get-sexp-start last-line-start)])
|
||||
(cond
|
||||
[(<= curr-open old-open) last-line-indent]
|
||||
[(not old-open) last-line-indent]
|
||||
[(and old-open (<= curr-open old-open)) last-line-indent]
|
||||
[else (+ single-tab-stop last-line-indent)]))]))]))])
|
||||
(build-string (max indent 0) (λ (x) #\space)))
|
||||
#;(let ([to-insert 0])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user