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 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 @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 @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) [(inferred-rule-name . rest)
(syntax->list #'rest)])] (syntax->list #'rest)])]
[(id val) [(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) [(lit val)
#'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))] #'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
[(token val) [(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. ;; Creates an stx out of the rule name and its components.
;; The location information of the rule spans that of 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) (define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:hide-or-splice? [hide-or-splice #f] . componentss)
(let ([spliced-componentss (append-map (λ(cs) (define (remove-rule-name cs) (cdr (syntax->list cs)))
(cond (define spliced-componentss
[(and (pair? cs) (eq? (syntax-property (car cs) 'hide-or-splice) 'hide)) (apply append
(list (list (syntax-case (car cs) () (for/list ([css (in-list componentss)])
[(rule-name c ...) (list
#'(c ...)])))] (cond
[(and (pair? cs) (or (eq? (syntax-property (car cs) 'hide-or-splice) 'splice) [(and (pair? css) (eq? (syntax-property (car css) 'hide-or-splice) 'hide))
(syntax-property (car cs) 'splice-rh-id))) (list (remove-rule-name (car css)))] ; hidden version still contained in sublist
(list (cdr (syntax->list (car cs))))] [(and (pair? css) (or (eq? (syntax-property (car css) 'hide-or-splice) 'splice)
[else (list cs)])) componentss)]) (syntax-property (car css) 'splice-rh-id)))
(syntax-property (remove-rule-name (car css))] ; spliced version is "unlisted"
(datum->syntax #f [else css])))))
(cons (syntax-property
(datum->syntax #f rule-name/false srcloc stx-with-original?-property) (datum->syntax #f
(apply append spliced-componentss)) (cons
srcloc (datum->syntax #f rule-name/false srcloc stx-with-original?-property)
stx-with-original?-property) (apply append spliced-componentss))
'hide-or-splice hide-or-splice))) ; not 'hide-or-splice-lhs-id, because it is now a component in a different rule 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)*] "]" 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 #lang racket/base
(require (for-syntax racket/base "parser.rkt"))
(require parser-tools/lex (require parser-tools/lex
(prefix-in : parser-tools/lex-sre) (prefix-in : parser-tools/lex-sre)
"parser.rkt" "parser.rkt"
@ -9,12 +10,15 @@
;; A newline can be any one of the following. ;; A newline can be any one of the following.
(define-lex-abbrev NL (:or "\r\n" "\r" "\n")) (define-lex-abbrev NL (:or "\r\n" "\r" "\n"))
;; Slightly modified from the read.rkt example in parser-tools, treating ;; chars used for quantifiers & parse-tree filtering
;; +, :, and * as reserved, non-identifier characters. (define-for-syntax quantifiers "+:*")
(define-lex-trans reserved-chars
(λ(stx) #`(char-set #,(format "~a~a~a" quantifiers hide-char splice-char))))
(define-lex-abbrevs (define-lex-abbrevs
[letter (:or (:/ "a" "z") (:/ #\A #\Z))] [letter (:or (:/ "a" "z") (:/ #\A #\Z))]
[digit (:/ #\0 #\9)] [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 (define-lex-abbrev id
@ -40,10 +44,10 @@
(token-RPAREN lexeme)] (token-RPAREN lexeme)]
["]" ["]"
(token-RBRACKET lexeme)] (token-RBRACKET lexeme)]
["!" ["/"
(token-BANG lexeme)] (token-HIDE lexeme)]
["@" ["@"
(token-ATSIGN lexeme)] (token-SPLICE lexeme)]
["|" ["|"
(token-PIPE lexeme)] (token-PIPE lexeme)]
[(:or "+" "*") [(:or "+" "*")
@ -61,7 +65,7 @@
(token-EOF lexeme)] (token-EOF lexeme)]
[(:: id (:* whitespace) ":") [(:: id (:* whitespace) ":")
(token-RULE_HEAD lexeme)] (token-RULE_HEAD lexeme)]
[(:: "!" id (:* whitespace) ":") [(:: "/" id (:* whitespace) ":")
(token-RULE_HEAD_HIDDEN lexeme)] (token-RULE_HEAD_HIDDEN lexeme)]
[(:: "@" id (:* whitespace) ":") [(:: "@" id (:* whitespace) ":")
(token-RULE_HEAD_SPLICED lexeme)] (token-RULE_HEAD_SPLICED lexeme)]

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

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

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

@ -13,11 +13,7 @@
'(json ":")) '(json ":"))
#;(check-equal? (check-equal?
(syntax->datum (syntax->datum
(parse "[[[{}]],[],[[{}]]]")) (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) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-token (p 8) (p 13) "COLON" #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) (list (rule (p 1) (p 14)
(lhs-id (p 1) (p 6) "expr" ''hide) (lhs-id (p 1) (p 6) "expr" ''hide)
(pattern-token (p 9) (p 14) "COLON" #f)))) (pattern-token (p 9) (p 14) "COLON" #f))))
@ -35,7 +35,7 @@
(lhs-id (p 1) (p 6) "expr" ''splice) (lhs-id (p 1) (p 6) "expr" ''splice)
(pattern-token (p 9) (p 14) "COLON" #f)))) (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) (list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20) (pattern-seq (p 8) (p 20)
@ -43,7 +43,7 @@
(pattern-token (p 8) (p 14) "COLON" 'hide) (pattern-token (p 8) (p 14) "COLON" 'hide)
(pattern-token (p 15) (p 20) "COLON" #f)))))) (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) (list (rule (p 1) (p 20)
(lhs-id (p 1) (p 5) "expr" #f) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 20) (pattern-seq (p 8) (p 20)
@ -73,7 +73,7 @@
1 1
(pattern-lit (p 8) (p 15) "hello" #f))))) (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) (list (rule (p 1) (p 18)
(lhs-id (p 1) (p 5) "expr" #f) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-maybe (p 8) (p 18) (pattern-maybe (p 8) (p 18)
@ -96,7 +96,7 @@
(list (pattern-token (p 23) (p 26) "BAZ" #f) (list (pattern-token (p 23) (p 26) "BAZ" #f)
(pattern-id (p 27) (p 31) "expr" #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) (list (rule (p 1) (p 22)
(lhs-id (p 1) (p 5) "expr" #f) (lhs-id (p 1) (p 5) "expr" #f)
(pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f) (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)