diff --git a/brag/codegen/runtime.rkt b/brag/codegen/runtime.rkt index 0182a61..9f5ff04 100755 --- a/brag/codegen/runtime.rkt +++ b/brag/codegen/runtime.rkt @@ -171,48 +171,61 @@ This would be the place to check a syntax property for hiding. (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property)) -(define (remove-rule-name component-stx #:splice? [splice #f]) - ;; when removing a rule name, we apply it as a syntax property to the remaining elements - ;; for possible later usage (aka, why throw away information) - (with-syntax ([(name . subcomponents) component-stx]) - (let ([name-datum (syntax->datum #'name)]) - (if splice - ;; when splicing, returned list is a regular list, with each element having the property. - (map (λ(sc) (syntax-property sc name-datum #'name)) (syntax->list #'subcomponents)) - ;; when hiding, returned list should be a syntaxed list with the property - ;; iow, basically the same as `component-stx`, minus the name - (syntax-property (datum->syntax component-stx #'subcomponents component-stx component-stx) name-datum #'name))))) - - -(define (preprocess-component-lists component-lists) - ; "preprocess" means splicing and rule-name-hiding where indicated +(define (apply-name-property name-stx stxs) + (for/list ([stx (in-list (syntax->list stxs))]) + (syntax-property stx (syntax->datum name-stx) name-stx))) + + +(define (splice-stx component-stx) + ;; when splicing, we apply rule name as a syntax property to the remaining elements + (syntax-case component-stx () + [(name . subcomponents) + (syntax-property #'name 'rule-id) ; name has not been removed (recognized by presence of 'rule-id) + (apply-name-property #'name #'subcomponents)] + [subcomponents ; name has been removed, but it is stored in 'generating-rule property + (let* ([name-datum (syntax-property #'subcomponents 'generating-rule)] + [name-stx (syntax-property #'subcomponents name-datum)]) + (apply-name-property name-stx #'subcomponents))])) + + +(define (remove-rule-name component-stx) + (syntax-case component-stx () + [(name . subcomponents) + (let ([name-datum (syntax->datum #'name)]) + (syntax-property + (syntax-property + (datum->syntax component-stx #'subcomponents component-stx component-stx) + name-datum #'name) + 'generating-rule name-datum))])) + + +(define (splice-component-lists component-lists) + ;; each `component-list` is a list that's either empty, or contains component-stx objects + ;; inside `component-stx` is a name followed by subcomponents (append* - ;; each `component-list` is a list that's either empty, or has a single component-stx object - ;; inside `component-stx` is a name followed by subcomponents (for*/list ([component-list (in-list component-lists)] - [component-stx (in-list component-list)]) ; this has the effect of omitting any empty `component-list` - (list - (cond - ;; test splice first in case both hiding and splicing are set, for instance: - ;; /rule : thing @rule - ;; otherwise the hide prevents the splice from being expressed - [(or (eq? (syntax-property component-stx 'hide-or-splice) 'splice) + #:unless (empty? component-list) + [component-stx (in-list component-list)]) + (if (or (eq? (syntax-property component-stx 'hide-or-splice) 'splice) (syntax-property component-stx 'splice-rh-id)) - (remove-rule-name component-stx #:splice? #t)] ; spliced version is lifted out of the sublist - [(eq? (syntax-property component-stx 'hide-or-splice) 'hide) - (list (remove-rule-name component-stx))] ; hidden version still wrapped in a sublist - [else (list component-stx)]))))) + (splice-stx component-stx) ; spliced version is lifted out of the sublist + (list component-stx))))) ; otherwise left inside sublist ;; rule-components->syntax: (U symbol false) (listof stx) ... #:srcloc (U #f (list src line column offset span)) -> stx ;; 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] . component-lists) - (define new-rule-name (datum->syntax #f rule-name/false srcloc stx-with-original?-property)) - (define new-rule-components (append* (preprocess-component-lists component-lists))) - (define rule-result (cons new-rule-name new-rule-components)) + (define new-rule-name (syntax-property + (datum->syntax #f rule-name/false srcloc stx-with-original?-property) + 'rule-id #t)) + (define rule-result (cons new-rule-name (splice-component-lists component-lists))) (define syntaxed-rule-result (datum->syntax #f rule-result srcloc stx-with-original?-property)) - ;; not 'hide-or-splice-lhs-id, because this will now become a (right-hand) component in a different (left-hand) rule - ;; actual splicing happens when the parent rule is processed (with procedure above) - (syntax-property syntaxed-rule-result 'hide-or-splice hide-or-splice)) + ;; not 'hide-or-splice-lhs-id, because this will now become + ;; a (right-hand) component in a different (left-hand) rule + ;; actual splicing happens when the parent rule is processed (with `splice-component-lists`) + (syntax-property ((if (eq? hide-or-splice 'hide) + remove-rule-name + values) syntaxed-rule-result) + 'hide-or-splice hide-or-splice)) diff --git a/brag/examples/hide-top.rkt b/brag/examples/hide-top.rkt new file mode 100644 index 0000000..499048c --- /dev/null +++ b/brag/examples/hide-top.rkt @@ -0,0 +1,2 @@ +#lang brag +/top : "x" \ No newline at end of file diff --git a/brag/test/test-all.rkt b/brag/test/test-all.rkt index 58e326d..160051c 100755 --- a/brag/test/test-all.rkt +++ b/brag/test/test-all.rkt @@ -11,6 +11,7 @@ "test-errors.rkt" "test-flatten.rkt" "test-hide-and-splice.rkt" + "test-hide-top.rkt" "test-lexer.rkt" "test-old-token.rkt" "test-parser.rkt" diff --git a/brag/test/test-hide-top.rkt b/brag/test/test-hide-top.rkt new file mode 100755 index 0000000..e21fc5b --- /dev/null +++ b/brag/test/test-hide-top.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require brag/examples/hide-top + brag/support + rackunit) + +;; check that the top rule name can be cut (hidden) + +(check-equal? (parse-to-datum "x") '("x")) \ No newline at end of file