change elide to struct / syntax prop ; tests pass

dev-elider
Matthew Butterick 8 years ago
parent 7bf8a29bd3
commit 3504667b83

@ -260,7 +260,7 @@
(let loop ([a-pattern a-pattern] (let loop ([a-pattern a-pattern]
[implicit implicit] [implicit implicit]
[explicit explicit]) [explicit explicit])
(syntax-case a-pattern (id lit token choice repeat maybe seq elide) (syntax-case a-pattern (id lit token choice repeat maybe seq)
[(id val) [(id val)
(values implicit explicit)] (values implicit explicit)]
[(lit val) [(lit val)
@ -280,11 +280,6 @@
[(maybe val) [(maybe val)
(loop #'val implicit explicit)] (loop #'val implicit explicit)]
[(seq vals ...) [(seq vals ...)
(for/fold ([implicit implicit]
[explicit explicit])
([v (in-list (syntax->list #'(vals ...)))])
(loop v implicit explicit))]
[(elide vals ...)
(for/fold ([implicit implicit] (for/fold ([implicit implicit]
[explicit explicit]) [explicit explicit])
([v (in-list (syntax->list #'(vals ...)))]) ([v (in-list (syntax->list #'(vals ...)))])
@ -347,7 +342,7 @@
(define (pattern-collect-used-ids a-pattern acc) (define (pattern-collect-used-ids a-pattern acc)
(let loop ([a-pattern a-pattern] (let loop ([a-pattern a-pattern]
[acc acc]) [acc acc])
(syntax-case a-pattern (id lit token choice repeat maybe seq elide) (syntax-case a-pattern (id lit token choice repeat maybe seq)
[(id val) [(id val)
(cons #'val acc)] (cons #'val acc)]
[(lit val) [(lit val)
@ -363,10 +358,6 @@
[(maybe val) [(maybe val)
(loop #'val acc)] (loop #'val acc)]
[(seq vals ...) [(seq vals ...)
(for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))])
(loop v acc))]
[(elide vals ...)
(for/fold ([acc acc]) (for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))]) ([v (in-list (syntax->list #'(vals ...)))])
(loop v acc))]))) (loop v acc))])))
@ -394,7 +385,7 @@
a-leaf) a-leaf)
(define (process-pattern a-pattern) (define (process-pattern a-pattern)
(syntax-case a-pattern (id lit token choice repeat maybe seq elide) (syntax-case a-pattern (id lit token choice repeat maybe seq)
[(id val) [(id val)
(free-id-table-ref toplevel-rule-table #'val)] (free-id-table-ref toplevel-rule-table #'val)]
[(lit val) [(lit val)
@ -417,13 +408,6 @@
[(maybe val) [(maybe val)
(make-leaf)] (make-leaf)]
[(seq vals ...) [(seq vals ...)
(begin
(define an-and-node (sat:make-and))
(for ([v (in-list (syntax->list #'(vals ...)))])
(define a-child (process-pattern v))
(sat:add-child! an-and-node a-child))
an-and-node)]
[(elide vals ...)
(begin (begin
(define an-and-node (sat:make-and)) (define an-and-node (sat:make-and))
(for ([v (in-list (syntax->list #'(vals ...)))]) (for ([v (in-list (syntax->list #'(vals ...)))])

@ -72,7 +72,7 @@
[origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])]) [origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
(syntax-case a-rule (rule) (syntax-case a-rule (rule)
[(rule name pat) [(rule name pat)
(syntax-case #'pat (id inferred-id lit token choice repeat maybe seq elide) (syntax-case #'pat (id inferred-id lit token choice repeat maybe seq)
;; The primitive types stay as they are: ;; The primitive types stay as they are:
[(id val) [(id val)
@ -124,14 +124,6 @@
inferred-rules)))] inferred-rules)))]
[(seq sub-pat ...) [(seq sub-pat ...)
(begin
(define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-patterns (syntax->list #'(sub-pat ...))))
(with-syntax ([(sub-pat ...) new-sub-pats])
(cons #'(head origin name [sub-pat ...])
inferred-rules)))]
[(elide sub-pat ...)
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-patterns (syntax->list #'(sub-pat ...)))) (lift-nonprimitive-patterns (syntax->list #'(sub-pat ...))))

@ -11,7 +11,7 @@
(token 'STRING "'hello world'") (token 'STRING "'hello world'")
"}"))) "}")))
'(json (object "{" '(json (object "{"
(kvpair "message" (json (string "'hello world'"))) (kvpair "message" ":" (json (string "'hello world'")))
"}"))) "}")))

@ -1,4 +1,4 @@
#lang racket/base #lang br
(require parser-tools/yacc (require parser-tools/yacc
parser-tools/lex parser-tools/lex
racket/list racket/list
@ -34,8 +34,7 @@
[struct-out pattern-choice] [struct-out pattern-choice]
[struct-out pattern-repeat] [struct-out pattern-repeat]
[struct-out pattern-maybe] [struct-out pattern-maybe]
[struct-out pattern-seq] [struct-out pattern-seq])
[struct-out pattern-elide])
(define-tokens tokens (LPAREN (define-tokens tokens (LPAREN
RPAREN RPAREN
@ -49,7 +48,7 @@
ID ID
LIT LIT
EOF)) EOF))
(require sugar/debug)
;; grammar-parser: (-> token) -> (listof rule) ;; grammar-parser: (-> token) -> (listof rule)
(define grammar-parser (define grammar-parser
(parser (parser
@ -83,7 +82,8 @@
(string-length trimmed)) (string-length trimmed))
(position-line $1-start-pos) (position-line $1-start-pos)
(position-col $1-start-pos)) (position-col $1-start-pos))
trimmed) trimmed
#f)
$2))]] $2))]]
[pattern [pattern
@ -129,16 +129,19 @@
[(LIT) [(LIT)
(pattern-lit (position->pos $1-start-pos) (pattern-lit (position->pos $1-start-pos)
(position->pos $1-end-pos) (position->pos $1-end-pos)
(substring $1 1 (sub1 (string-length $1))))] (substring $1 1 (sub1 (string-length $1)))
#f)]
[(ID) [(ID)
(if (token-id? $1) (if (token-id? $1)
(pattern-token (position->pos $1-start-pos) (pattern-token (position->pos $1-start-pos)
(position->pos $1-end-pos) (position->pos $1-end-pos)
$1) $1
#f)
(pattern-id (position->pos $1-start-pos) (pattern-id (position->pos $1-start-pos)
(position->pos $1-end-pos) (position->pos $1-end-pos)
$1))] $1
#f))]
[(LBRACKET pattern RBRACKET) [(LBRACKET pattern RBRACKET)
(pattern-maybe (position->pos $1-start-pos) (pattern-maybe (position->pos $1-start-pos)
@ -149,7 +152,8 @@
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))] (relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]
[(LANGLE pattern RANGLE) [(LANGLE pattern RANGLE)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]]) ;; angles indicate hiding. set hide value to #t
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos) #t)]])
(error (lambda (tok-ok? tok-name tok-value start-pos end-pos) (error (lambda (tok-ok? tok-name tok-value start-pos end-pos)
@ -158,14 +162,14 @@
;; relocate-pattern: pattern -> pattern ;; relocate-pattern: pattern -> pattern
;; Rewrites the pattern's start and end pos accordingly. ;; Rewrites the pattern's start and end pos accordingly.
(define (relocate-pattern a-pat start-pos end-pos) (define (relocate-pattern a-pat start-pos end-pos [hide? #f])
(match a-pat (match a-pat
[(pattern-id _ _ v) [(pattern-id _ _ v h)
(pattern-id start-pos end-pos v)] (pattern-id start-pos end-pos v (or hide? h))]
[(pattern-token _ _ v) [(pattern-token _ _ v h)
(pattern-token start-pos end-pos v)] (pattern-token start-pos end-pos v (or hide? h))]
[(pattern-lit _ _ v) [(pattern-lit _ _ v h)
(pattern-lit start-pos end-pos v)] (pattern-lit start-pos end-pos v (or hide? h))]
[(pattern-choice _ _ vs) [(pattern-choice _ _ vs)
(pattern-choice start-pos end-pos vs)] (pattern-choice start-pos end-pos vs)]
[(pattern-repeat _ _ m v) [(pattern-repeat _ _ m v)
@ -174,8 +178,6 @@
(pattern-maybe start-pos end-pos v)] (pattern-maybe start-pos end-pos v)]
[(pattern-seq _ _ vs) [(pattern-seq _ _ vs)
(pattern-seq start-pos end-pos vs)] (pattern-seq start-pos end-pos vs)]
[(pattern-elide _ _ vs)
(pattern-elide start-pos end-pos vs)]
[else [else
(error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)])) (error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))

@ -12,7 +12,7 @@
(struct rule (start end lhs pattern) (struct rule (start end lhs pattern)
#:transparent) #:transparent)
(struct lhs-id (start end val) (struct lhs-id (start end val hide)
#:transparent) #:transparent)
@ -20,16 +20,16 @@
(struct pattern (start end) (struct pattern (start end)
#:transparent) #:transparent)
(struct pattern-id pattern (val) (struct pattern-id pattern (val hide)
#:transparent) #:transparent)
;; Token structure to be defined by the user ;; Token structure to be defined by the user
(struct pattern-token pattern (val) (struct pattern-token pattern (val hide)
#:transparent) #:transparent)
;; Token structure defined as the literal string to be matched. ;; Token structure defined as the literal string to be matched.
(struct pattern-lit pattern (val) (struct pattern-lit pattern (val hide)
#:transparent) #:transparent)
(struct pattern-choice pattern (vals) (struct pattern-choice pattern (vals)
@ -45,6 +45,3 @@
(struct pattern-seq pattern (vals) (struct pattern-seq pattern (vals)
#:transparent) #:transparent)
(struct pattern-elide pattern (vals)
#:transparent)

@ -13,5 +13,4 @@
(define (choice stx) (raise-syntax-error #f "Used out of context of rules" stx)) (define (choice stx) (raise-syntax-error #f "Used out of context of rules" stx))
(define (repeat stx) (raise-syntax-error #f "Used out of context of rules" stx)) (define (repeat stx) (raise-syntax-error #f "Used out of context of rules" stx))
(define (maybe stx) (raise-syntax-error #f "Used out of context of rules" stx)) (define (maybe stx) (raise-syntax-error #f "Used out of context of rules" stx))
(define (seq stx) (raise-syntax-error #f "Used out of context of rules" stx)) (define (seq stx) (raise-syntax-error #f "Used out of context of rules" stx))
(define (elide stx) (raise-syntax-error #f "Used out of context of rules" stx))

@ -57,22 +57,30 @@
(pos-offset (pattern-start a-pattern))) (pos-offset (pattern-start a-pattern)))
#f)) #f))
(define source-location (list source line column position span)) (define source-location (list source line column position span))
(datum->syntax #f (match a-pattern
(match a-pattern [(struct pattern-id (start end val hide))
[(struct pattern-id (start end val)) (syntax-property
`(id ,(datum->syntax #f (string->symbol val) source-location))] (datum->syntax #f
[(struct pattern-lit (start end val)) `(id ,(datum->syntax #f (string->symbol val) source-location))
`(lit ,(datum->syntax #f val source-location))] source-location)
[(struct pattern-token (start end val)) 'hide hide)]
`(token ,(datum->syntax #f (string->symbol val) source-location))] [(struct pattern-lit (start end val hide))
[(struct pattern-choice (start end vals)) (syntax-property
`(choice ,@(map recur vals))] (datum->syntax #f
[(struct pattern-repeat (start end min val)) `(lit ,(datum->syntax #f val source-location))
`(repeat ,min ,(recur val))] source-location)
[(struct pattern-maybe (start end val)) 'hide hide)]
`(maybe ,(recur val))] [(struct pattern-token (start end val hide))
[(struct pattern-seq (start end vals)) (syntax-property
`(seq ,@(map recur vals))] (datum->syntax #f
[(struct pattern-elide (start end vals)) `(token ,(datum->syntax #f (string->symbol val) source-location))
`(elide ,@(map recur vals))]) source-location)
source-location)) 'hide hide)]
[(struct pattern-choice (start end vals))
(datum->syntax #f`(choice ,@(map recur vals)) source-location)]
[(struct pattern-repeat (start end min val))
(datum->syntax #f`(repeat ,min ,(recur val)) source-location)]
[(struct pattern-maybe (start end val))
(datum->syntax #f`(maybe ,(recur val)) source-location)]
[(struct pattern-seq (start end vals))
(datum->syntax #f`(seq ,@(map recur vals)) source-location)]))

@ -17,97 +17,97 @@
;; FIXME: fix the test cases so they work on locations rather than just offsets. ;; FIXME: fix the test cases so they work on locations rather than just offsets.
(check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'")))
(list (rule (p 1) (p 15) (list (rule (p 1) (p 15)
(lhs-id (p 1) (p 5) "expr" ) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-lit (p 8) (p 15) "hello")))) (pattern-lit (p 8) (p 15) "hello" #f))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON")))
(list (rule (p 1) (p 13) (list (rule (p 1) (p 13)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-token (p 8) (p 13) "COLON")))) (pattern-token (p 8) (p 13) "COLON" #f))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON COLON"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : <COLON> COLON")))
(list (rule (p 1) (p 19) (list (rule (p 1) (p 21)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 19) (pattern-seq (p 8) (p 21)
(list (list
(pattern-token (p 8) (p 13) "COLON") (pattern-token (p 8) (p 15) "COLON" #t)
(pattern-token (p 14) (p 19) "COLON")))))) (pattern-token (p 16) (p 21) "COLON" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'*"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'*")))
(list (rule (p 1) (p 16) (list (rule (p 1) (p 16)
(lhs-id (p 1) (p 5) "expr" ) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-repeat (p 8) (p 16) (pattern-repeat (p 8) (p 16)
0 0
(pattern-lit (p 8) (p 15) "hello"))))) (pattern-lit (p 8) (p 15) "hello" #f)))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'+"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'+")))
(list (rule (p 1) (p 16) (list (rule (p 1) (p 16)
(lhs-id (p 1) (p 5) "expr" ) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-repeat (p 8) (p 16) (pattern-repeat (p 8) (p 16)
1 1
(pattern-lit (p 8) (p 15) "hello"))))) (pattern-lit (p 8) (p 15) "hello" #f)))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : ['hello']"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : ['hello']")))
(list (rule (p 1) (p 17) (list (rule (p 1) (p 17)
(lhs-id (p 1) (p 5) "expr" ) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-maybe (p 8) (p 17) (pattern-maybe (p 8) (p 17)
(pattern-lit (p 9) (p 16) "hello"))))) (pattern-lit (p 9) (p 16) "hello" #f)))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH")))
(list (rule (p 1) (p 20) (list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-choice (p 8) (p 20) (pattern-choice (p 8) (p 20)
(list (pattern-token (p 8) (p 13) "COLON") (list (pattern-token (p 8) (p 13) "COLON" #f)
(pattern-token (p 16) (p 20) "BLAH")))))) (pattern-token (p 16) (p 20) "BLAH" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH | BAZ expr"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH | BAZ expr")))
(list (rule (p 1) (p 31) (list (rule (p 1) (p 31)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-choice (p 8) (p 31) (pattern-choice (p 8) (p 31)
(list (pattern-token (p 8) (p 13) "COLON") (list (pattern-token (p 8) (p 13) "COLON" #f)
(pattern-token (p 16) (p 20) "BLAH") (pattern-token (p 16) (p 20) "BLAH" #f)
(pattern-seq (p 23) (p 31) (pattern-seq (p 23) (p 31)
(list (pattern-token (p 23) (p 26) "BAZ") (list (pattern-token (p 23) (p 26) "BAZ" #f)
(pattern-id (p 27) (p 31) "expr")))))))) (pattern-id (p 27) (p 31) "expr" #f))))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two three"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : one two three")))
(list (rule (p 1) (p 21) (list (rule (p 1) (p 21)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 21) (list (pattern-id (p 8) (p 11) "one") (pattern-seq (p 8) (p 21) (list (pattern-id (p 8) (p 11) "one" #f)
(pattern-id (p 12) (p 15) "two") (pattern-id (p 12) (p 15) "two" #f)
(pattern-id (p 16) (p 21) "three")))))) (pattern-id (p 16) (p 21) "three" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two three)"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two three)")))
(list (rule (p 1) (p 23) (list (rule (p 1) (p 23)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 23) (list (pattern-id (p 9) (p 12) "one") (pattern-seq (p 8) (p 23) (list (pattern-id (p 9) (p 12) "one" #f)
(pattern-id (p 13) (p 16) "two") (pattern-id (p 13) (p 16) "two" #f)
(pattern-id (p 17) (p 22) "three")))))) (pattern-id (p 17) (p 22) "three" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two* three"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : one two* three")))
(list (rule (p 1) (p 22) (list (rule (p 1) (p 22)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one") (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
(pattern-repeat (p 12) (p 16) 0 (pattern-id (p 12) (p 15) "two")) (pattern-repeat (p 12) (p 16) 0 (pattern-id (p 12) (p 15) "two" #f))
(pattern-id (p 17) (p 22) "three")))))) (pattern-id (p 17) (p 22) "three" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two+ three"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : one two+ three")))
(list (rule (p 1) (p 22) (list (rule (p 1) (p 22)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one") (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
(pattern-repeat (p 12) (p 16) 1 (pattern-id (p 12) (p 15) "two")) (pattern-repeat (p 12) (p 16) 1 (pattern-id (p 12) (p 15) "two" #f))
(pattern-id (p 17) (p 22) "three")))))) (pattern-id (p 17) (p 22) "three" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two)+ three"))) (check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two)+ three")))
(list (rule (p 1) (p 24) (list (rule (p 1) (p 24)
(lhs-id (p 1) (p 5) "expr") (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 24) (list (pattern-repeat (p 8) (p 18) 1 (pattern-seq (p 8) (p 24) (list (pattern-repeat (p 8) (p 18) 1
(pattern-seq (p 8) (p 17) (pattern-seq (p 8) (p 17)
(list (pattern-id (p 9) (p 12) "one") (list (pattern-id (p 9) (p 12) "one" #f)
(pattern-id (p 13) (p 16) "two")))) (pattern-id (p 13) (p 16) "two" #f))))
(pattern-id (p 19) (p 24) "three")))))) (pattern-id (p 19) (p 24) "three" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string #<<EOF (check-equal? (grammar-parser (tokenize (open-input-string #<<EOF
@ -117,13 +117,13 @@ stat: ID '=' expr
EOF EOF
))) )))
(list (rule (p 1) (p 17) (list (rule (p 1) (p 17)
(lhs-id (p 1) (p 9) "statlist") (lhs-id (p 1) (p 9) "statlist" #f)
(pattern-repeat (p 12) (p 17) 1 (pattern-id (p 12) (p 16) "stat"))) (pattern-repeat (p 12) (p 17) 1 (pattern-id (p 12) (p 16) "stat" #f)))
(rule (p 18) (p 54) (rule (p 18) (p 54)
(lhs-id (p 18) (p 22) "stat") (lhs-id (p 18) (p 22) "stat" #f)
(pattern-choice (p 24) (p 54) (list (pattern-seq (p 24) (p 35) (list (pattern-token (p 24) (p 26) "ID") (pattern-choice (p 24) (p 54) (list (pattern-seq (p 24) (p 35) (list (pattern-token (p 24) (p 26) "ID" #f)
(pattern-lit (p 27) (p 30) "=") (pattern-lit (p 27) (p 30) "=" #f)
(pattern-id (p 31) (p 35) "expr"))) (pattern-id (p 31) (p 35) "expr" #f)))
(pattern-seq (p 42) (p 54) (list (pattern-lit (p 42) (p 49) "print") (pattern-seq (p 42) (p 54) (list (pattern-lit (p 42) (p 49) "print" #f)
(pattern-id (p 50) (p 54) "expr")))))))) (pattern-id (p 50) (p 54) "expr" #f))))))))

Loading…
Cancel
Save