diff --git a/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt b/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt index d5594a8..f62281e 100755 --- a/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt +++ b/beautiful-racket-ragg/br/ragg/codegen/codegen.rkt @@ -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)) diff --git a/beautiful-racket-ragg/br/ragg/codegen/flatten.rkt b/beautiful-racket-ragg/br/ragg/codegen/flatten.rkt index 44a78d3..d400d60 100755 --- a/beautiful-racket-ragg/br/ragg/codegen/flatten.rkt +++ b/beautiful-racket-ragg/br/ragg/codegen/flatten.rkt @@ -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 ...)))])) diff --git a/beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt alias b/beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt alias deleted file mode 100644 index f550a79..0000000 Binary files a/beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt alias and /dev/null differ diff --git a/beautiful-racket-ragg/br/ragg/elider/json-elider.rkt b/beautiful-racket-ragg/br/ragg/elider/json-elider.rkt new file mode 100755 index 0000000..9db268b --- /dev/null +++ b/beautiful-racket-ragg/br/ragg/elider/json-elider.rkt @@ -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 diff --git a/beautiful-racket-ragg/br/ragg/elider/test-json-elider.rkt b/beautiful-racket-ragg/br/ragg/elider/test-json-elider.rkt new file mode 100755 index 0000000..4bed939 --- /dev/null +++ b/beautiful-racket-ragg/br/ragg/elider/test-json-elider.rkt @@ -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 #\{ #\})) #\])) #\])) #\]))) + + + + diff --git a/beautiful-racket-ragg/br/ragg/info.rkt b/beautiful-racket-ragg/br/ragg/info.rkt index 8ea5d35..8b0f69a 100755 --- a/beautiful-racket-ragg/br/ragg/info.rkt +++ b/beautiful-racket-ragg/br/ragg/info.rkt @@ -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"))) diff --git a/beautiful-racket-ragg/br/ragg/rules/lexer.rkt b/beautiful-racket-ragg/br/ragg/rules/lexer.rkt index 8022b65..3f03d8a 100755 --- a/beautiful-racket-ragg/br/ragg/rules/lexer.rkt +++ b/beautiful-racket-ragg/br/ragg/rules/lexer.rkt @@ -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 "+" "*") diff --git a/beautiful-racket-ragg/br/ragg/rules/parser.rkt b/beautiful-racket-ragg/br/ragg/rules/parser.rkt index 27a5822..7c5b92b 100755 --- a/beautiful-racket-ragg/br/ragg/rules/parser.rkt +++ b/beautiful-racket-ragg/br/ragg/rules/parser.rkt @@ -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 diff --git a/beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt b/beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt index 28dfcef..b4f7a18 100755 --- a/beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt +++ b/beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt @@ -42,6 +42,9 @@ (struct pattern-maybe pattern (val) #:transparent) +(struct pattern-elide pattern (val) + #:transparent) + (struct pattern-seq pattern (vals) #:transparent) diff --git a/beautiful-racket-ragg/br/ragg/rules/stx-types.rkt b/beautiful-racket-ragg/br/ragg/rules/stx-types.rkt index e0ac70a..cb6356e 100755 --- a/beautiful-racket-ragg/br/ragg/rules/stx-types.rkt +++ b/beautiful-racket-ragg/br/ragg/rules/stx-types.rkt @@ -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)) \ No newline at end of file diff --git a/beautiful-racket-ragg/br/ragg/rules/stx.rkt b/beautiful-racket-ragg/br/ragg/rules/stx.rkt index 013fd50..3fab9b2 100755 --- a/beautiful-racket-ragg/br/ragg/rules/stx.rkt +++ b/beautiful-racket-ragg/br/ragg/rules/stx.rkt @@ -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)) diff --git a/beautiful-racket/br/demo/txtadv/world-test.rkt b/beautiful-racket/br/demo/txtadv/world-test.rkt index c5c6edf..80a4b04 100644 --- a/beautiful-racket/br/demo/txtadv/world-test.rkt +++ b/beautiful-racket/br/demo/txtadv/world-test.rkt @@ -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")