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

148
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]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
#;(!!! (printf "terminal ~a~n" name)) #;(!!! (printf "terminal ~a~n" name))
#;(!!! (printf "input ~a~n" (cons? input))) #;(!!! (printf "input ~a~n" (pair? input)))
#;(!!! (if (eq? input return-name) #;(!!! (printf "input ~a~n" (null? input)))
(printf "dummy given~n") #;(!!! (cond
(let ([token (!!! ((!!! position-token-token) (!!! (car input))))]) [(eq? input return-name)
(!!! (printf "Look at token ~a~n" token)) (printf "dummy given~n")]
(!!! (printf "calling token-name: ~a~n" ((!!! token-name) token))) [(null? input) (printf "null given~n")]
(!!! (printf "calling pred: ~a~n" (pred token))) [else
(!!! (printf "called pred~n")) (let ([token (!!! ((!!! position-token-token) (!!! (car input))))])
(!!! (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 (cond
[(eq? input return-name) name] [(eq? input return-name) name]
[(null? input) [(null? input)
@ -104,7 +108,8 @@
(lambda (r) (lambda (r)
(cond (cond
[(res? r) [(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) name (res-id r) (res-used r)
(res-possible-error r) (res-possible-error r)
(res-first-tok r))] (res-first-tok r))]
@ -115,7 +120,7 @@
(res-used (repeat-res-a r)) (res-used (repeat-res-a r))
(repeat-res-stop r) (repeat-res-stop r)
(res-first-tok (repeat-res-a 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-error (sequence-error-gen name sequence-length)]
[my-walker (seq-walker id-position name my-error)]) [my-walker (seq-walker id-position name my-error)])
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
@ -134,6 +139,7 @@
[else pre-build-ans])]) [else pre-build-ans])])
(hash-table-put! memo-table input ans) (hash-table-put! memo-table input ans)
#;(!!! (printf "sequence ~a returning ~n" name)) #;(!!! (printf "sequence ~a returning ~n" name))
#;(!!! (printf "answer is ~a ~n" ans))
ans)]))))) ans)])))))
;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result ;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))) (or id (res-id (repeat-res-a rst)))
(+ used (res-used (repeat-res-a rst))) (+ used (res-used (repeat-res-a rst)))
(repeat-res-stop rst) tok)] (repeat-res-stop rst) tok)]
[else (printf "~a~n" rst) (error 'stop2)] [else (error 'parser-internal-error2 rst)]
))] ))]
[walker [walker
(lambda (subs input previous? look-back curr-id seen used alts last-src) (lambda (subs input previous? look-back curr-id seen used alts last-src)
@ -180,6 +186,8 @@
[(choice-res? rsts) [(choice-res? rsts)
(map (lambda (rst) (next-res old-answer new-id old-used tok rst)) (map (lambda (rst) (next-res old-answer new-id old-used tok rst))
(correct-list (choice-res-matches rsts)))] (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)])))]) [else (printf "~a~n" rsts) (error 'here2)])))])
(cond (cond
[(null? next-preds) [(null? next-preds)
@ -288,12 +296,23 @@
(cond (cond
[(and (pair? old-res) (null? (cdr old-res))) (car old-res)] [(and (pair? old-res) (null? (cdr old-res))) (car old-res)]
[(repeat-res? old-res) [(repeat-res? old-res)
(cond (let ([inner-res (repeat-res-a old-res)]
[(fail-type? (repeat-res-stop old-res)) [stop (repeat-res-stop old-res)])
(let ([res (repeat-res-a old-res)]) (cond
(make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res) [stop
(repeat-res-stop old-res) (res-first-tok res)))] (make-res (res-a inner-res)
[else (repeat-res-a old-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)) [(or (and (res? old-res) (res-a old-res))
(choice-res? old-res) (choice-res? old-res)
(pair? old-res)) old-res] (pair? old-res)) old-res]
@ -307,6 +326,11 @@
(> (fail-type-chance (repeat-res-stop look-back)) (> (fail-type-chance (repeat-res-stop look-back))
(fail-type-chance (res-msg old-res)))) (fail-type-chance (res-msg old-res))))
(repeat-res-stop look-back)] (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)])] [else (res-msg old-res)])]
[(next-ok?) [(next-ok?)
(and (= (fail-type-may-use fail) 1) (and (= (fail-type-may-use fail) 1)
@ -331,6 +355,17 @@
(fail-type-name (res-msg old-res)) (fail-type-name (res-msg old-res))
(and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back))) (and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back)))
(fail-type-chance (res-msg old-res)))) (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" #;(printf "old-probability ~a new probability ~a~n"
(cond (cond
[(= 0 used) (fail-type-chance fail)] [(= 0 used) (fail-type-chance fail)]
@ -441,30 +476,33 @@
[(hash-table-get memo-table input #f) (hash-table-get memo-table input)] [(hash-table-get memo-table input #f) (hash-table-get memo-table input)]
[(eq? input return-name) name] [(eq? input return-name) name]
[else [else
(let* ([options (map (lambda (term) (term input last-src sub-opts)) opt-list)] (let*-values
#;[a (!!! (printf "choice-options ~a ~n ~a ~n~n~n" choice-names options))] ([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)]
[fails (map (lambda (x) (if (res? x) (res-msg x) (error 'here-non-res))) #;[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)] options)]
[corrects (correct-list options)] [(corrects errors) (split-list options)]
[ans [(fail-builder)
(cond (lambda (fails)
[(null? corrects) (if (null? fails)
(fail-res input #f
(make-choice-fail (rank-choice (map fail-type-chance fails)) (make-choice-fail (rank-choice (map fail-type-chance fails))
(if (or (null? input) (if (or (null? input)
(not (position-token? (car input)))) (not (position-token? (car input))))
last-src last-src
(update-src-end (update-src-end
last-src last-src
(position-token-end-pos (car input)))) (position-token-end-pos (car input))))
name name
(rank-choice (map fail-type-used fails)) (rank-choice (map fail-type-used fails))
(rank-choice (map fail-type-may-use fails)) (rank-choice (map fail-type-may-use fails))
num-choices choice-names num-choices choice-names
(null? input) (null? input)
fails))] fails)))]
[(null? (cdr corrects)) (car corrects)] [(ans)
[else (make-choice-res name corrects)])]) (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)) #;(!!! (printf "choice ~a is returning ~a options were ~a ~n" name ans choice-names))
(hash-table-put! memo-table input ans) ans)]))))) (hash-table-put! memo-table input ans) ans)])))))
@ -485,6 +523,31 @@
[(null? subs) null] [(null? subs) null]
[else (printf "subs~a~n" subs) (error 'stop5)])) [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) (define (update-src-start src new-start)
(list (position-line new-start) (list (position-line new-start)
(position-col new-start) (position-col new-start)
@ -494,6 +557,7 @@
(fourth src)))) (fourth src))))
(define (update-src-end src new-end) (define (update-src-end src new-end)
(when (null? src) (error 'update-src-end))
(list (max (first src) 1) (list (max (first src) 1)
(second src) (second src)
(max (third src) 1) (max (third src) 1)
@ -503,7 +567,7 @@
(letrec ([name (string-append "any number of "(op return-name))] (letrec ([name (string-append "any number of "(op return-name))]
[r* (choice (list op [r* (choice (list op
(seq (list op r*) (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) name)
(seq null (lambda (x) null) return-name)) (seq null (lambda (x) null) return-name))
name)]) name)])

18
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)])) (input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
message-to-date)] message-to-date)]
[(sequence-fail? fail-type) [(sequence-fail? fail-type)
#;(printf "sequence-fail case: kind is ~a~n" (sequence-fail-kind fail-type))
(let* ([id-name (let* ([id-name
(if (sequence-fail-id fail-type) (if (sequence-fail-id fail-type)
(string-append name " " (sequence-fail-id fail-type)) name)] (string-append name " " (sequence-fail-id fail-type)) name)]
@ -91,14 +92,19 @@
[(options) [(options)
(let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type)) (let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type))
(lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))]) (lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))])
(fail-type->message (car sorted-opts) (if (null? show-sequence)
(add-to-message (fail-type->message (car sorted-opts)
(msg (format "There is an error in this ~a after ~a, it is likely you intended a(n) ~a here.~n" (add-to-message (msg (format "This ~a did not start as expected." id-name))
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)))]))]
(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) [(options-fail? fail-type)
#;(printf "selecting for options on ~a~n" name) #;(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)] [top-names (map fail-type-name winners)]
[non-dup-tops (remove-dups top-names name)] [non-dup-tops (remove-dups top-names name)]
[top-name (car top-names)]) [top-name (car top-names)])

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 ;(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)) (define-struct res (a rest msg id used possible-error first-tok) (make-inspector))
;make-choice-res string (listof res) ;make-choice-res string (listof res fail-type)
(define-struct choice-res (name matches)) (define-struct choice-res (name matches errors))
;(make-repeat-res answer (U symbol fail-type)) ;(make-repeat-res answer (U symbol fail-type))
(define-struct repeat-res (a stop) (make-inspector)) (define-struct repeat-res (a stop) (make-inspector))

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

@ -411,8 +411,8 @@
(define checks (define checks
(choose (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")) "check expression"))
) )
@ -652,13 +652,13 @@
(sequence (O_PAREN (eta expression) C_PAREN) id) (sequence (O_PAREN (eta expression) C_PAREN) id)
(sequence (! (eta expression)) id "conditional expression") (sequence (! (eta expression)) id "conditional expression")
(sequence (MINUS (eta expression)) id "negation expression") (sequence (MINUS (eta expression)) id "negation expression")
checks) "expression")) checks) "expression -unique base"))
(define unique-end (define unique-end
(choose (field-access-end (choose (field-access-end
method-call-end method-call-end
(binary-expression-end (bin-ops (list math-ops compare-ops bool-ops)))) (binary-expression-end (bin-ops (list math-ops compare-ops bool-ops))))
"expression")) "expression -unique end"))
(define expression (define expression
(sequence (unique-base (repeat-greedy unique-end)) id "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))] [last-line-indent (sub1 (- last-line-start previous-line))]
[old-open (get-sexp-start last-line-start)]) [old-open (get-sexp-start last-line-start)])
(cond (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)]))]))]))]) [else (+ single-tab-stop last-line-indent)]))]))]))])
(build-string (max indent 0) (λ (x) #\space))) (build-string (max indent 0) (λ (x) #\space)))
#;(let ([to-insert 0]) #;(let ([to-insert 0])