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

refactor ; change hiding char to slash

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-10 16:33:03 -07:00
parent 975d0da0f5
commit 61890e18ee
9 changed files with 77 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
beautiful-racket/br/demo/txtadv/parser.rkt
View File

@ -2,34 +2,34 @@
txtadv-program : verb-section everywhere-section things-section places-section start-section
verb-section : !"===VERBS===" verb-item+
verb-section : /"===VERBS===" verb-item+
!verb-item : verb next-verb* s-exp
/verb-item : verb next-verb* s-exp
!verb : ID ["_"]
/verb : ID ["_"]
@next-verb : [!","] verb
@next-verb : [/","] verb
everywhere-section : !"===EVERYWHERE===" id-desc+
everywhere-section : /"===EVERYWHERE===" id-desc+
things-section : !"===THINGS===" thing-item+
things-section : /"===THINGS===" thing-item+
!thing-item : DASHED-NAME id-desc+
/thing-item : DASHED-NAME id-desc+
places-section : !"===PLACES===" place-item+
places-section : /"===PLACES===" place-item+
!place-item : DASHED-NAME STRING place-items id-desc+
/place-item : DASHED-NAME STRING place-items id-desc+
!place-items : !"[" [place next-place*] !"]"
/place-items : /"[" [place next-place*] /"]"
@place : ID
@next-place: !"," place
@next-place: /"," place
start-section : !"===START===" ID
start-section : /"===START===" ID
!id-desc : ID s-exp
/id-desc : ID s-exp
@s-exp : ID | STRING | nested-s-exp
!nested-s-exp : !"(" s-exp* !")"
/nested-s-exp : /"(" s-exp* /")"

6
brag/brag/codegen/codegen.rkt
View File

@ -217,7 +217,11 @@
[(inferred-rule-name . rest)
(syntax->list #'rest)])]
[(id val)
#`(list (syntax-property $X 'splice-rh-id #,(and (syntax-property primitive-pattern 'hide) #t)))] ; at this point, this syntax-property is either #f or "splice"
;; at this point, the 'hide property is either #f or "splice"
;; ('hide value is handled at the top of this conditional
;; we need to use boolean because a symbol is treated as an identifier.
;; also we'll separate it into its own property for clarity and test for it in "runtime.rkt"
#`(list (syntax-property $X 'splice-rh-id #,(and (syntax-property primitive-pattern 'hide) #t)))]
[(lit val)
#'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
[(token val)

40
brag/brag/codegen/runtime.rkt
View File

@ -162,21 +162,25 @@ This would be the place to check a syntax property for hiding.
;; Creates an stx out of the rule name and its components.
;; The location information of the rule spans that of its components.
(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:hide-or-splice? [hide-or-splice #f] . componentss)
(let ([spliced-componentss (append-map (λ(cs)
(cond
[(and (pair? cs) (eq? (syntax-property (car cs) 'hide-or-splice) 'hide))
(list (list (syntax-case (car cs) ()
[(rule-name c ...)
#'(c ...)])))]
[(and (pair? cs) (or (eq? (syntax-property (car cs) 'hide-or-splice) 'splice)
(syntax-property (car cs) 'splice-rh-id)))
(list (cdr (syntax->list (car cs))))]
[else (list cs)])) componentss)])
(syntax-property
(datum->syntax #f
(cons
(datum->syntax #f rule-name/false srcloc stx-with-original?-property)
(apply append spliced-componentss))
srcloc
stx-with-original?-property)
'hide-or-splice hide-or-splice))) ; not 'hide-or-splice-lhs-id, because it is now a component in a different rule
(define (remove-rule-name cs) (cdr (syntax->list cs)))
(define spliced-componentss
(apply append
(for/list ([css (in-list componentss)])
(list
(cond
[(and (pair? css) (eq? (syntax-property (car css) 'hide-or-splice) 'hide))
(list (remove-rule-name (car css)))] ; hidden version still contained in sublist
[(and (pair? css) (or (eq? (syntax-property (car css) 'hide-or-splice) 'splice)
(syntax-property (car css) 'splice-rh-id)))
(remove-rule-name (car css))] ; spliced version is "unlisted"
[else css])))))
(syntax-property
(datum->syntax #f
(cons
(datum->syntax #f rule-name/false srcloc stx-with-original?-property)
(apply append spliced-componentss))
srcloc
stx-with-original?-property)
;; not 'hide-or-splice-lhs-id, because it is now a component in a different rule
;; actual splicing happens when the parent rule is processed (with procedure above)
'hide-or-splice hide-or-splice))

4
brag/brag/examples/baby-json-hider.rkt
View File

@ -11,6 +11,6 @@ string: STRING
array: "[" [json ("," json)*] "]"
object: !"{" [kvpair ("," kvpair)*] !"}"
object: /"{" [kvpair ("," kvpair)*] /"}"
@kvpair : !ID ":" !json
@kvpair : /ID ":" /json

18
brag/brag/rules/lexer.rkt
View File

@ -1,4 +1,5 @@
#lang racket/base
(require (for-syntax racket/base "parser.rkt"))
(require parser-tools/lex
(prefix-in : parser-tools/lex-sre)
"parser.rkt"
@ -9,12 +10,15 @@
;; A newline can be any one of the following.
(define-lex-abbrev NL (:or "\r\n" "\r" "\n"))
;; Slightly modified from the read.rkt example in parser-tools, treating
;; +, :, and * as reserved, non-identifier characters.
;; chars used for quantifiers & parse-tree filtering
(define-for-syntax quantifiers "+:*")
(define-lex-trans reserved-chars
(λ(stx) #`(char-set #,(format "~a~a~a" quantifiers hide-char splice-char))))
(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 "+:*@!-.$%&/=?^_~<>") (char-complement (reserved-chars))))]
)
(define-lex-abbrev id
@ -40,10 +44,10 @@
(token-RPAREN lexeme)]
["]"
(token-RBRACKET lexeme)]
["!"
(token-BANG lexeme)]
["/"
(token-HIDE lexeme)]
["@"
(token-ATSIGN lexeme)]
(token-SPLICE lexeme)]
["|"
(token-PIPE lexeme)]
[(:or "+" "*")
@ -61,7 +65,7 @@
(token-EOF lexeme)]
[(:: id (:* whitespace) ":")
(token-RULE_HEAD lexeme)]
[(:: "!" id (:* whitespace) ":")
[(:: "/" id (:* whitespace) ":")
(token-RULE_HEAD_HIDDEN lexeme)]
[(:: "@" id (:* whitespace) ":")
(token-RULE_HEAD_SPLICED lexeme)]

28
brag/brag/rules/parser.rkt
View File

@ -7,11 +7,13 @@
;; A parser for grammars.
(provide tokens
(provide hide-char
splice-char
tokens
token-LPAREN
token-RPAREN
token-BANG ; for hider
token-ATSIGN ; for splicer
token-HIDE ; for hider
token-SPLICE ; for splicer
token-LBRACKET
token-RBRACKET
token-PIPE
@ -42,8 +44,8 @@
RPAREN
LBRACKET
RBRACKET
BANG
ATSIGN
HIDE
SPLICE
PIPE
REPEAT
RULE_HEAD
@ -53,6 +55,9 @@
LIT
EOF))
(define hide-char #\/)
(define splice-char #\@)
;; grammar-parser: (-> token) -> (listof rule)
(define grammar-parser
(parser
@ -92,7 +97,7 @@
[(RULE_HEAD_HIDDEN pattern) ; bang indicates hiding
(begin
(define trimmed (cadr (regexp-match #px"!(\\S+)\\s*:$" $1)))
(define trimmed (cadr (regexp-match (pregexp (format "~a(\\S+)\\s*:$" hide-char)) $1)))
(rule (position->pos $1-start-pos)
(position->pos $2-end-pos)
(lhs-id (position->pos $1-start-pos)
@ -107,7 +112,7 @@
[(RULE_HEAD_SPLICED pattern) ;atsign indicates splicinh
(begin
(define trimmed (cadr (regexp-match #px"@(\\S+)\\s*:$" $1)))
(define trimmed (cadr (regexp-match (pregexp (format "~a(\\S+)\\s*:$" splice-char)) $1)))
(rule (position->pos $1-start-pos)
(position->pos $2-end-pos)
(lhs-id (position->pos $1-start-pos)
@ -185,13 +190,12 @@
[(LPAREN pattern RPAREN)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]
[(BANG atomic-pattern)
;; bang indicates hiding. set hide value to hide
[(HIDE atomic-pattern)
(relocate-pattern $2 (position->pos $1-start-pos) (position->pos $2-end-pos) 'hide)]
[(ATSIGN ID)
;; atsign indicates splicing. set hide value to splice
;; only works for nonterminals on the right side (meaningless with terminals)
[(SPLICE ID)
;; only works for nonterminals on the right side
;; (meaningless with terminals)
(if (token-id? $2)
(error 'brag "Can't use splice operator with terminal")
(pattern-id (position->pos $1-start-pos)

1
brag/brag/rules/rule-structs.rkt
View File

@ -20,7 +20,6 @@
(struct pattern-id pattern (val hide)
#:transparent)
;; Token structure to be defined by the user
(struct pattern-token pattern (val hide)
#:transparent)

8
brag/brag/test/test-baby-json-hider.rkt
View File

@ -13,11 +13,7 @@
'(json ":"))
#;(check-equal?
(check-equal?
(syntax->datum
(parse "[[[{}]],[],[[{}]]]"))
'(json (array #\[ (json (array #\[ (json (array #\[ (json (object)) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object )) #\])) #\])) #\])))
'(json (array #\[ (json (array #\[ (json (array #\[ (json) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json) #\])) #\])) #\])))

10
brag/brag/test/test-parser.rkt
View File

@ -25,7 +25,7 @@
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-token (p 8) (p 13) "COLON" #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 14)
(lhs-id (p 1) (p 6) "expr" ''hide)
(pattern-token (p 9) (p 14) "COLON" #f))))
@ -35,7 +35,7 @@
(lhs-id (p 1) (p 6) "expr" ''splice)
(pattern-token (p 9) (p 14) "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 20)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20)
@ -43,7 +43,7 @@
(pattern-token (p 8) (p 14) "COLON" 'hide)
(pattern-token (p 15) (p 20) "COLON" #f))))))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : !thing COLON")))
(check-equal? (grammar-parser (tokenize (open-input-string "expr : /thing COLON")))
(list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20)
@ -73,7 +73,7 @@
1
(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 18)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-maybe (p 8) (p 18)
@ -96,7 +96,7 @@
(list (pattern-token (p 23) (p 26) "BAZ" #f)
(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 22)
(lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)