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

Fixing bugs in parsing selection, and in indenting

Browse Source 
svn: r6996
This commit is contained in:
Kathy Gray 2007-08-01 23:33:11 +00:00
parent 92f1e3fed2
commit 94a30c2e14
6 changed files with 127 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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")
#;(!!! (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)))))))
#;(!!! (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)
(let ([inner-res (repeat-res-a old-res)]
[stop (repeat-res-stop 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)])]
[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,15 +476,16 @@
[(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)]
(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)))
[(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
[(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))))
@ -462,9 +498,11 @@
(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)])])
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)])

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

@ -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,11 +92,16 @@
[(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 (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)))]))]
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))]

4
collects/combinator-parser/private-combinator/structs.scm
View File

@ -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))

8
collects/profj/comb-parsers/parser-units.scm
View File

@ -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"))

3
collects/profj/tool.ss
View File

@ -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])