hmm

beautiful-racket-ragg/br/ragg/codegen/codegen.rkt

@@ -172,8 +172,11 @@
        (with-syntax ([(translated-clause ...) translated-clauses])
          #`[name translated-clause ...]))]))
 
-  
+#|
-
+MB: This function generates the input for the parse tree,
+passing it to the two functions in "runtime.rkt".
+|#
+(require (only-in sugar/debug report report*))
 ;; translates a single primitive rule clause.
 ;; A clause is a simple list of ids, lit, vals, and inferred-id elements.
 ;; The action taken depends on the pattern type.
@@ -210,6 +213,7 @@
           ;; whose head is the name of the inferred rule . We strip that out,
           ;; leaving the residue to be absorbed.
           [(inferred-id val reason)
+           (report* #'val #'reason)
            #'(syntax-case $X ()
                [(inferred-rule-name . rest)
                 (syntax->list #'rest)])]

beautiful-racket-ragg/br/ragg/codegen/runtime.rkt

@@ -141,6 +141,10 @@
             #f)))
 
 
+#|
+MB: The next three functions control the appearance of the generated parse tree.
+|#
+
 ;; We create a syntax using read-syntax; by definition, it should have the
 ;; original? property set to #t, which we then copy over to syntaxes constructed
 ;; with atomic-datum->syntax and rule-components->syntax.
@@ -152,7 +156,7 @@
 ;; Helper that does the ugly work in wrapping a datum into a syntax
 ;; with source location.
 (define (atomic-datum->syntax d start-pos end-pos)
-  (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property))
+  (syntax-property (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property) 'foo 'atom))
 
 
 
@@ -161,10 +165,10 @@
 ;; The location information of the rule spans that of its components.
 (define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] . components)
   (define flattened-components (apply append components))
-  (datum->syntax #f 
+  (syntax-property (datum->syntax #f 
                  (apply append
                         (list 
-                         (datum->syntax #f rule-name/false srcloc stx-with-original?-property))
+                         (syntax-property (datum->syntax #f rule-name/false srcloc stx-with-original?-property) 'foo 'rule-name))
                         components)
                  srcloc
-                 stx-with-original?-property))
+                 stx-with-original?-property) 'foo 'whole-rule))

beautiful-racket-ragg/br/ragg/test/test-baby-json.rkt

@@ -14,8 +14,14 @@
                 (kvpair "message" ":" (json (string "'hello world'")))
                 "}")))
 
+(require sugar/debug)
+(syntax-property (report (cadr (syntax->list (cadr (syntax->list (parse (list "{" 
+               (token 'ID "message")
+               ":"
+               (token 'STRING "'hello world'")
+               "}"))))))) 'foo)
 
-(check-equal? 
+#;(check-equal? 
  (syntax->datum
   (parse "[[[{}]],[],[[{}]]]"))
  '(json (array #\[ (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object #\{ #\})) #\])) #\])) #\])))