diff --git a/brag/brag/codegen/flatten.rkt b/brag/brag/codegen/flatten.rkt index e1d9baf..ad3ecfc 100755 --- a/brag/brag/codegen/flatten.rkt +++ b/brag/brag/codegen/flatten.rkt @@ -44,17 +44,17 @@ ;; derived rules. (define (lift-nonprimitive-pattern a-pat) (cond - [(primitive-pattern? a-pat) - (values '() (linearize-primitive-pattern a-pat))] - [(hash-has-key? ht (pattern->hash-key a-pat)) - (values '() (list (hash-ref ht (pattern->hash-key a-pat))))] - [else - (define head (syntax-case a-pat () [(head rest ...) #'head])) - (define new-name (datum->syntax #f (fresh-name) a-pat)) - (define new-inferred-id (datum->syntax #f `(inferred-id ,new-name ,head) a-pat)) - (hash-set! ht (pattern->hash-key a-pat) new-inferred-id) - (values (recur #`(rule #,new-name #,a-pat) head) - (list new-inferred-id))])) + [(primitive-pattern? a-pat) + (values '() (linearize-primitive-pattern a-pat))] + [(hash-has-key? ht (pattern->hash-key a-pat)) + (values '() (list (hash-ref ht (pattern->hash-key a-pat))))] + [else + (define head (syntax-case a-pat () [(head rest ...) #'head])) + (define new-name (datum->syntax #f (fresh-name) a-pat)) + (define new-inferred-id (datum->syntax #f `(inferred-id ,new-name ,head) a-pat)) + (hash-set! ht (pattern->hash-key a-pat) new-inferred-id) + (values (recur #`(rule #,new-name #,a-pat) head) + (list new-inferred-id))])) (define (lift-nonprimitive-patterns pats) (define-values (rules patterns) @@ -105,12 +105,12 @@ (with-syntax ([(sub-pat ...) new-sub-pats]) (cons (cond [(= (syntax-e #'min) 0) #`(head origin name - [(inferred-id name repeat) sub-pat ...] - [])] + [(inferred-id name repeat) sub-pat ...] + [])] [(= (syntax-e #'min) 1) #`(head origin name - [(inferred-id name repeat) sub-pat ...] - [sub-pat ...])]) + [(inferred-id name repeat) sub-pat ...] + [sub-pat ...])]) inferred-rules)))] [(maybe sub-pat) @@ -133,8 +133,22 @@ ;; Given a pattern, return a key appropriate for a hash. +;; +;; In the `ragg` days this used `syntax->datum` only. +;; The problem is that with cuts & splices in the mix, it creates ambiguity: +;; e.g., the pattern (/"," foo)* and ("," foo)* differ only in the 'hide syntax property +;; so `syntax->datum` does not capture their differences. +;; That means they produced the same hash key, +;; which meant they produced the same inferred pattern. Which is wrong. +;; So we adjust the key to take account of the 'hide property +;; by "lifting" it into the datum with cons. +;; Then the pattern-inference process treats them separately. (define (pattern->hash-key a-pat) - (syntax->datum a-pat)) + (let loop ([x a-pat]) + (let ([maybe-stx-list (syntax->list x)]) + (if maybe-stx-list + (cons (syntax-property x 'hide) (map loop maybe-stx-list)) + (syntax->datum x))))) ;; Returns true if the pattern looks primitive diff --git a/brag/brag/examples/cutter.rkt b/brag/brag/examples/cutter.rkt new file mode 100755 index 0000000..7cd7023 --- /dev/null +++ b/brag/brag/examples/cutter.rkt @@ -0,0 +1,4 @@ +#lang brag +top : expr (/"," expr)* +expr : "x" | list +list : "(" expr ("," expr)* ")" \ No newline at end of file diff --git a/brag/brag/test/test-cutter.rkt b/brag/brag/test/test-cutter.rkt new file mode 100755 index 0000000..f4a14ac --- /dev/null +++ b/brag/brag/test/test-cutter.rkt @@ -0,0 +1,9 @@ +#lang racket/base +(require brag/examples/cutter + brag/support + rackunit) + +;; related to rule-flattening problem +(check-equal? + (parse-to-datum (list "(" "x" "," "x" ")")) + '(top (expr (list "(" (expr "x") "," (expr "x") ")")))) \ No newline at end of file