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

angle brackets behave ; tests pass

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-04 15:44:26 -07:00
parent 831d5cca35
commit e4a3255f6c
9 changed files with 138 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
beautiful-racket-ragg/br/ragg/codegen/codegen.rkt
View File

@ -260,7 +260,7 @@
(let loop ([a-pattern a-pattern]
[implicit implicit]
[explicit explicit])
(syntax-case a-pattern (id lit token choice repeat maybe elide seq)
(syntax-case a-pattern (id lit token choice elide repeat maybe seq)
[(id val)
(values implicit explicit)]
[(lit val)
@ -275,12 +275,15 @@
[explicit explicit])
([v (in-list (syntax->list #'(vals ...)))])
(loop v implicit explicit))]
[(elide vals ...)
(for/fold ([implicit implicit]
[explicit explicit])
([v (in-list (syntax->list #'(vals ...)))])
(loop v implicit explicit))]
[(repeat min val)
(loop #'val implicit explicit)]
[(maybe val)
(loop #'val implicit explicit)]
[(elide val)
(loop #'val implicit explicit)]
[(seq vals ...)
(for/fold ([implicit implicit]
[explicit explicit])
@ -344,7 +347,7 @@
(define (pattern-collect-used-ids a-pattern acc)
(let loop ([a-pattern a-pattern]
[acc acc])
(syntax-case a-pattern (id lit token choice repeat maybe elide seq)
(syntax-case a-pattern (id lit token choice elide repeat maybe seq)
[(id val)
(cons #'val acc)]
[(lit val)
@ -355,12 +358,14 @@
(for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))])
(loop v acc))]
[(elide vals ...)
(for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))])
(loop v acc))]
[(repeat min val)
(loop #'val acc)]
[(maybe val)
(loop #'val acc)]
[(elide val)
(loop #'val acc)]
[(seq vals ...)
(for/fold ([acc acc])
([v (in-list (syntax->list #'(vals ...)))])
@ -389,7 +394,7 @@
a-leaf)
(define (process-pattern a-pattern)
(syntax-case a-pattern (id lit token choice repeat maybe elide seq)
(syntax-case a-pattern (id lit token choice elide repeat maybe seq)
[(id val)
(free-id-table-ref toplevel-rule-table #'val)]
[(lit val)
@ -403,6 +408,13 @@
(define a-child (process-pattern v))
(sat:add-child! an-or-node a-child))
an-or-node)]
[(elide vals ...)
(begin
(define an-or-node (sat:make-or))
(for ([v (in-list (syntax->list #'(vals ...)))])
(define a-child (process-pattern v))
(sat:add-child! an-or-node a-child))
an-or-node)]
[(repeat min val)
(syntax-case #'min ()
[0
@ -411,8 +423,6 @@
(process-pattern #'val)])]
[(maybe val)
(make-leaf)]
[(elide val)
(make-leaf)]
[(seq vals ...)
(begin
(define an-and-node (sat:make-and))

30
beautiful-racket-ragg/br/ragg/codegen/flatten.rkt
View File

@ -72,7 +72,7 @@
[origin (syntax-case a-rule (rule) [(rule name (pat-head rest ...)) #'pat-head])])
(syntax-case a-rule (rule)
[(rule name pat)
(syntax-case #'pat (id inferred-id lit token choice repeat maybe elide seq)
(syntax-case #'pat (id inferred-id lit token choice elide repeat maybe seq)
;; The primitive types stay as they are:
[(id val)
@ -98,6 +98,18 @@
(append (list #'(head origin name [sub-pat ...] ...))
(apply append (reverse inferred-ruless/rev)))))]
[(elide sub-pat ...)
(begin
(define-values (inferred-ruless/rev new-sub-patss/rev)
(for/fold ([rs '()] [ps '()])
([p (syntax->list #'(sub-pat ...))])
(let-values ([(new-r new-p)
(lift-nonprimitive-pattern p)])
(values (cons new-r rs) (cons new-p ps)))))
(with-syntax ([((sub-pat ...) ...) (reverse new-sub-patss/rev)])
(append (list #'(head origin name [sub-pat ...] ...))
(apply append (reverse inferred-ruless/rev)))))]
[(repeat min sub-pat)
(begin
(define-values (inferred-rules new-sub-pats)
@ -123,16 +135,6 @@
[])
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 ...)
(begin
(define-values (inferred-rules new-sub-pats)
@ -149,7 +151,7 @@
;; Returns true if the pattern looks primitive
(define (primitive-pattern? a-pat)
(syntax-case a-pat (id lit token choice repeat maybe elide seq)
(syntax-case a-pat (id lit token choice elide repeat maybe seq)
[(id val)
#t]
[(lit val)
@ -158,12 +160,12 @@
#t]
[(choice sub-pat ...)
#f]
[(elide sub-pat)
#f]
[(repeat min val)
#f]
[(maybe sub-pat)
#f]
[(elide sub-pat)
#f]
[(seq sub-pat ...)
(andmap primitive-pattern? (syntax->list #'(sub-pat ...)))]))

7
beautiful-racket-ragg/br/ragg/elider/json-elider.rkt
View File

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

2
beautiful-racket-ragg/br/ragg/elider/test-json-elider.rkt
View File

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

2
beautiful-racket-ragg/br/ragg/rules/lexer.rkt
View File

@ -14,7 +14,7 @@
(define-lex-abbrevs
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
[digit (:/ #\0 #\9)]
[id-char (:or letter digit (char-set "-.!$%&/<=>?^_~@"))]
[id-char (:or letter digit (char-set "-.!$%&/=?^_~@"))]
)
(define-lex-abbrev id

20
beautiful-racket-ragg/br/ragg/rules/parser.rkt
View File

@ -10,10 +10,10 @@
(provide tokens
token-LPAREN
token-RPAREN
token-LBRACKET
token-RBRACKET
token-LANGLE ; for elider
token-RANGLE ; for elider
token-LBRACKET
token-RBRACKET
token-PIPE
token-REPEAT
token-RULE_HEAD
@ -32,9 +32,9 @@
[struct-out pattern-lit]
[struct-out pattern-token]
[struct-out pattern-choice]
[struct-out pattern-elide]
[struct-out pattern-repeat]
[struct-out pattern-maybe]
[struct-out pattern-elide]
[struct-out pattern-seq])
(define-tokens tokens (LPAREN
@ -49,7 +49,7 @@
ID
LIT
EOF))
(require sugar/debug)
;; grammar-parser: (-> token) -> (listof rule)
(define grammar-parser
(parser
@ -145,12 +145,10 @@
(position->pos $3-end-pos)
$2)]
[(LANGLE pattern RANGLE)
(pattern-elide (position->pos $1-start-pos)
(position->pos $3-end-pos)
$2)]
[(LPAREN pattern RPAREN)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]
[(LANGLE pattern RANGLE)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]])
@ -170,12 +168,12 @@
(pattern-lit start-pos end-pos v)]
[(pattern-choice _ _ vs)
(pattern-choice start-pos end-pos vs)]
[(pattern-elide _ _ vs)
(pattern-elide start-pos end-pos vs)]
[(pattern-repeat _ _ m v)
(pattern-repeat start-pos end-pos m v)]
[(pattern-maybe _ _ v)
(pattern-maybe start-pos end-pos v)]
[(pattern-elide _ _ v)
(pattern-elide start-pos end-pos v)]
[(pattern-seq _ _ vs)
(pattern-seq start-pos end-pos vs)]
[else

6
beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt
View File

@ -35,6 +35,9 @@
(struct pattern-choice pattern (vals)
#:transparent)
(struct pattern-elide pattern (val)
#:transparent)
(struct pattern-repeat pattern (min ;; either 0 or 1
val)
#:transparent)
@ -42,9 +45,6 @@
(struct pattern-maybe pattern (val)
#:transparent)
(struct pattern-elide pattern (val)
#:transparent)
(struct pattern-seq pattern (vals)
#:transparent)

2
beautiful-racket-ragg/br/ragg/rules/stx-types.rkt
View File

@ -11,7 +11,7 @@
(define (lit stx) (raise-syntax-error #f "Used out of context of rules" stx))
(define (token 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 (elide 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 (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))

4
beautiful-racket-ragg/br/ragg/rules/stx.rkt
View File

@ -67,12 +67,12 @@
`(token ,(datum->syntax #f (string->symbol val) source-location))]
[(struct pattern-choice (start end vals))
`(choice ,@(map recur vals))]
[(struct pattern-elide (start end vals))
`(elide ,@(map recur vals))]
[(struct pattern-repeat (start end min val))
`(repeat ,min ,(recur val))]
[(struct pattern-maybe (start end val))
`(maybe ,(recur val))]
[(struct pattern-elide (start end val))
`(elide ,(recur val))]
[(struct pattern-seq (start end vals))
`(seq ,@(map recur vals))])
source-location))