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

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

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-04 15:13:15 -07:00
parent 894c9780d8
commit 831d5cca35
12 changed files with 117 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

BIN
beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt alias
View File

Binary file not shown.

16
beautiful-racket-ragg/br/ragg/elider/json-elider.rkt Executable file
View File

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

25
beautiful-racket-ragg/br/ragg/elider/test-json-elider.rkt Executable file
View File

@ -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 #\{ #\})) #\])) #\])) #\])))

1
beautiful-racket-ragg/br/ragg/info.rkt
View File

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

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

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

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

@ -12,6 +12,8 @@
token-RPAREN
token-LBRACKET
token-RBRACKET
token-LANGLE ; for elider
token-RANGLE ; for elider
token-PIPE
token-REPEAT
token-RULE_HEAD
@ -19,7 +21,7 @@
token-LIT
token-EOF
grammar-parser
current-source
current-parser-error-handler
@ -32,12 +34,15 @@
[struct-out pattern-choice]
[struct-out pattern-repeat]
[struct-out pattern-maybe]
[struct-out pattern-elide]
[struct-out pattern-seq])
(define-tokens tokens (LPAREN
RPAREN
LBRACKET
RBRACKET
LANGLE
RANGLE
PIPE
REPEAT
RULE_HEAD
@ -52,17 +57,17 @@
(src-pos)
(start rules)
(end EOF)
(grammar
[rules
[(rules*) $1]]
[rules*
[(rule rules*)
(cons $1 $2)]
[()
'()]]
;; I have a separate token type for rule identifiers to avoid the
;; shift/reduce conflict that happens with the implicit sequencing
;; of top-level rules. i.e. the parser can't currently tell, when
@ -80,7 +85,7 @@
(position-col $1-start-pos))
trimmed)
$2))]]
[pattern
[(implicit-pattern-sequence PIPE pattern)
(if (pattern-choice? $3)
@ -92,7 +97,7 @@
(list $1 $3)))]
[(implicit-pattern-sequence)
$1]]
[implicit-pattern-sequence
[(repeatable-pattern implicit-pattern-sequence)
(if (pattern-seq? $2)
@ -104,7 +109,7 @@
(list $1 $2)))]
[(repeatable-pattern)
$1]]
[repeatable-pattern
[(atomic-pattern REPEAT)
(cond [(string=? $2 "*")
@ -119,7 +124,7 @@
(error 'grammar-parse "unknown repetition operator ~e" $2)])]
[(atomic-pattern)
$1]]
[atomic-pattern
[(LIT)
(pattern-lit (position->pos $1-start-pos)
@ -134,15 +139,20 @@
(pattern-id (position->pos $1-start-pos)
(position->pos $1-end-pos)
$1))]
[(LBRACKET pattern RBRACKET)
(pattern-maybe (position->pos $1-start-pos)
(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))]])
(error (lambda (tok-ok? tok-name tok-value start-pos end-pos)
((current-parser-error-handler) tok-ok? tok-name tok-value (position->pos start-pos) (position->pos end-pos))))))
@ -152,22 +162,24 @@
;; Rewrites the pattern's start and end pos accordingly.
(define (relocate-pattern a-pat start-pos end-pos)
(match a-pat
[(pattern-id _ _ v)
(pattern-id start-pos end-pos v)]
[(pattern-token _ _ v)
(pattern-token start-pos end-pos v)]
[(pattern-lit _ _ v)
(pattern-lit start-pos end-pos v)]
[(pattern-choice _ _ vs)
(pattern-choice 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-seq _ _ vs)
(pattern-seq start-pos end-pos vs)]
[else
(error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))
[(pattern-id _ _ v)
(pattern-id start-pos end-pos v)]
[(pattern-token _ _ v)
(pattern-token start-pos end-pos v)]
[(pattern-lit _ _ v)
(pattern-lit start-pos end-pos v)]
[(pattern-choice _ _ vs)
(pattern-choice 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
(error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))
; token-id: string -> boolean
@ -194,9 +206,9 @@
;; When bad things happen, we need to emit errors with source location.
(struct exn:fail:parse-grammar exn:fail (srclocs)
#:transparent
#:property prop:exn:srclocs (lambda (instance)
(exn:fail:parse-grammar-srclocs instance)))
#:transparent
#:property prop:exn:srclocs (lambda (instance)
(exn:fail:parse-grammar-srclocs instance)))
(define current-parser-error-handler
(make-parameter

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

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

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

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

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

@ -71,6 +71,8 @@
`(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))

3
beautiful-racket/br/demo/txtadv/world-test.rkt
View File

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