`elide` token added with no functional changes; all tests still pass

dev-elider
Matthew Butterick 9 years ago
parent 894c9780d8
commit 831d5cca35

@ -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) (syntax-case a-pattern (id lit token choice repeat maybe elide seq)
[(id val) [(id val)
(values implicit explicit)] (values implicit explicit)]
[(lit val) [(lit val)
@ -279,6 +279,8 @@
(loop #'val implicit explicit)] (loop #'val implicit explicit)]
[(maybe val) [(maybe val)
(loop #'val implicit explicit)] (loop #'val implicit explicit)]
[(elide val)
(loop #'val implicit explicit)]
[(seq vals ...) [(seq vals ...)
(for/fold ([implicit implicit] (for/fold ([implicit implicit]
[explicit explicit]) [explicit explicit])
@ -342,7 +344,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) (syntax-case a-pattern (id lit token choice repeat maybe elide seq)
[(id val) [(id val)
(cons #'val acc)] (cons #'val acc)]
[(lit val) [(lit val)
@ -357,6 +359,8 @@
(loop #'val acc)] (loop #'val acc)]
[(maybe val) [(maybe val)
(loop #'val acc)] (loop #'val acc)]
[(elide val)
(loop #'val acc)]
[(seq vals ...) [(seq vals ...)
(for/fold ([acc acc]) (for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))]) ([v (in-list (syntax->list #'(vals ...)))])
@ -385,7 +389,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) (syntax-case a-pattern (id lit token choice repeat maybe elide 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)
@ -407,6 +411,8 @@
(process-pattern #'val)])] (process-pattern #'val)])]
[(maybe val) [(maybe val)
(make-leaf)] (make-leaf)]
[(elide val)
(make-leaf)]
[(seq vals ...) [(seq vals ...)
(begin (begin
(define an-and-node (sat:make-and)) (define an-and-node (sat:make-and))

@ -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) (syntax-case #'pat (id inferred-id lit token choice repeat maybe elide seq)
;; The primitive types stay as they are: ;; The primitive types stay as they are:
[(id val) [(id val)
@ -123,6 +123,16 @@
[]) [])
inferred-rules)))] inferred-rules)))]
[(elide sub-pat)
(begin
(define-values (inferred-rules new-sub-pats)
(lift-nonprimitive-pattern #'sub-pat))
(with-syntax ([(sub-pat ...) new-sub-pats])
(cons #'(head origin name
[sub-pat ...]
[])
inferred-rules)))]
[(seq sub-pat ...) [(seq sub-pat ...)
(begin (begin
(define-values (inferred-rules new-sub-pats) (define-values (inferred-rules new-sub-pats)
@ -139,7 +149,7 @@
;; Returns true if the pattern looks primitive ;; Returns true if the pattern looks primitive
(define (primitive-pattern? a-pat) (define (primitive-pattern? a-pat)
(syntax-case a-pat (id lit token choice repeat maybe seq) (syntax-case a-pat (id lit token choice repeat maybe elide seq)
[(id val) [(id val)
#t] #t]
[(lit val) [(lit val)
@ -152,6 +162,8 @@
#f] #f]
[(maybe sub-pat) [(maybe sub-pat)
#f] #f]
[(elide sub-pat)
#f]
[(seq sub-pat ...) [(seq sub-pat ...)
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))])) (andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]))

@ -0,0 +1,16 @@
#lang br/ragg
;; Simple baby example of JSON structure
json: number | string
| array
| object
number: NUMBER
string: STRING
array: "[" [json ("," json)*] "]"
object: "{" [kvpair ("," kvpair)*] "}"
kvpair: ID <":"> json

@ -0,0 +1,25 @@
#lang racket/base
(require "json-elider.rkt"
br/ragg/support
rackunit)
(check-equal?
(syntax->datum
(parse (list "{"
(token 'ID "message")
":"
(token 'STRING "'hello world'")
"}")))
'(json (object "{"
(kvpair "message" (json (string "'hello world'")))
"}")))
#;(check-equal?
(syntax->datum
(parse "[[[{}]],[],[[{}]]]"))
'(json (array #\[ (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\])))

@ -2,7 +2,6 @@
(define name "ragg") (define name "ragg")
(define categories '(devtools)) (define categories '(devtools))
(define can-be-loaded-with 'all) (define can-be-loaded-with 'all)
(define required-core-version "5.3.1")
(define version "1.0") (define version "1.0")
(define repositories '("4.x")) (define repositories '("4.x"))
(define scribblings '(("br-ragg.scrbl"))) (define scribblings '(("br-ragg.scrbl")))

@ -39,10 +39,14 @@
(token-LPAREN lexeme)] (token-LPAREN lexeme)]
["[" ["["
(token-LBRACKET lexeme)] (token-LBRACKET lexeme)]
["<"
(token-LANGLE lexeme)]
[")" [")"
(token-RPAREN lexeme)] (token-RPAREN lexeme)]
["]" ["]"
(token-RBRACKET lexeme)] (token-RBRACKET lexeme)]
[">"
(token-RANGLE lexeme)]
["|" ["|"
(token-PIPE lexeme)] (token-PIPE lexeme)]
[(:or "+" "*") [(:or "+" "*")

@ -12,6 +12,8 @@
token-RPAREN token-RPAREN
token-LBRACKET token-LBRACKET
token-RBRACKET token-RBRACKET
token-LANGLE ; for elider
token-RANGLE ; for elider
token-PIPE token-PIPE
token-REPEAT token-REPEAT
token-RULE_HEAD token-RULE_HEAD
@ -32,12 +34,15 @@
[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-elide]
[struct-out pattern-seq]) [struct-out pattern-seq])
(define-tokens tokens (LPAREN (define-tokens tokens (LPAREN
RPAREN RPAREN
LBRACKET LBRACKET
RBRACKET RBRACKET
LANGLE
RANGLE
PIPE PIPE
REPEAT REPEAT
RULE_HEAD RULE_HEAD
@ -140,6 +145,11 @@
(position->pos $3-end-pos) (position->pos $3-end-pos)
$2)] $2)]
[(LANGLE pattern RANGLE)
(pattern-elide (position->pos $1-start-pos)
(position->pos $3-end-pos)
$2)]
[(LPAREN pattern RPAREN) [(LPAREN pattern RPAREN)
(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))]])
@ -164,6 +174,8 @@
(pattern-repeat start-pos end-pos m v)] (pattern-repeat start-pos end-pos m v)]
[(pattern-maybe _ _ v) [(pattern-maybe _ _ v)
(pattern-maybe start-pos end-pos v)] (pattern-maybe start-pos end-pos v)]
[(pattern-elide _ _ v)
(pattern-elide 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)]
[else [else

@ -42,6 +42,9 @@
(struct pattern-maybe pattern (val) (struct pattern-maybe pattern (val)
#:transparent) #:transparent)
(struct pattern-elide pattern (val)
#:transparent)
(struct pattern-seq pattern (vals) (struct pattern-seq pattern (vals)
#:transparent) #:transparent)

@ -13,4 +13,5 @@
(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 (elide 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))

@ -71,6 +71,8 @@
`(repeat ,min ,(recur val))] `(repeat ,min ,(recur val))]
[(struct pattern-maybe (start end val)) [(struct pattern-maybe (start end val))
`(maybe ,(recur val))] `(maybe ,(recur val))]
[(struct pattern-elide (start end val))
`(elide ,(recur val))]
[(struct pattern-seq (start end vals)) [(struct pattern-seq (start end vals))
`(seq ,@(map recur vals))]) `(seq ,@(map recur vals))])
source-location)) source-location))

@ -1,4 +1,4 @@
#lang at-exp racket #lang racket
(require rackunit) (require rackunit)
(require "world.rkt") (require "world.rkt")
@ -20,6 +20,7 @@
"get key" "get key"
"You now have the key.\n") "You now have the key.\n")
(check-cmd? (check-cmd?
"n" "n"
"You're standing in a meadow. There is a house to the north.\n") "You're standing in a meadow. There is a house to the north.\n")

Loading…
Cancel
Save