diff --git a/beautiful-racket/br/demo/txtadv/parser.rkt b/beautiful-racket/br/demo/txtadv/parser.rkt index a0d41e1..0b1b68b 100644 --- a/beautiful-racket/br/demo/txtadv/parser.rkt +++ b/beautiful-racket/br/demo/txtadv/parser.rkt @@ -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* !")" \ No newline at end of file +/nested-s-exp : /"(" s-exp* /")" \ No newline at end of file diff --git a/brag/brag/codegen/codegen.rkt b/brag/brag/codegen/codegen.rkt index 3ffddc3..a44b12a 100755 --- a/brag/brag/codegen/codegen.rkt +++ b/brag/brag/codegen/codegen.rkt @@ -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) diff --git a/brag/brag/codegen/runtime.rkt b/brag/brag/codegen/runtime.rkt index 931b738..b0b2828 100755 --- a/brag/brag/codegen/runtime.rkt +++ b/brag/brag/codegen/runtime.rkt @@ -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 \ No newline at end of file + (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)) \ No newline at end of file diff --git a/brag/brag/examples/baby-json-hider.rkt b/brag/brag/examples/baby-json-hider.rkt index 11731ff..acbe349 100755 --- a/brag/brag/examples/baby-json-hider.rkt +++ b/brag/brag/examples/baby-json-hider.rkt @@ -11,6 +11,6 @@ string: STRING array: "[" [json ("," json)*] "]" -object: !"{" [kvpair ("," kvpair)*] !"}" +object: /"{" [kvpair ("," kvpair)*] /"}" -@kvpair : !ID ":" !json +@kvpair : /ID ":" /json diff --git a/brag/brag/rules/lexer.rkt b/brag/brag/rules/lexer.rkt index 0667a5f..df4c9e8 100755 --- a/brag/brag/rules/lexer.rkt +++ b/brag/brag/rules/lexer.rkt @@ -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)] diff --git a/brag/brag/rules/parser.rkt b/brag/brag/rules/parser.rkt index b359f5b..b04983c 100755 --- a/brag/brag/rules/parser.rkt +++ b/brag/brag/rules/parser.rkt @@ -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) diff --git a/brag/brag/rules/rule-structs.rkt b/brag/brag/rules/rule-structs.rkt index a667b09..7e9c082 100755 --- a/brag/brag/rules/rule-structs.rkt +++ b/brag/brag/rules/rule-structs.rkt @@ -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) diff --git a/brag/brag/test/test-baby-json-hider.rkt b/brag/brag/test/test-baby-json-hider.rkt index a52e74f..65209dd 100755 --- a/brag/brag/test/test-baby-json-hider.rkt +++ b/brag/brag/test/test-baby-json-hider.rkt @@ -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) #\])) #\])) #\]))) diff --git a/brag/brag/test/test-parser.rkt b/brag/brag/test/test-parser.rkt index a075a17..a0d35c1 100755 --- a/brag/brag/test/test-parser.rkt +++ b/brag/brag/test/test-parser.rkt @@ -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)