hmm

.travis.yml

@@ -14,8 +14,6 @@ env:
 #    - RACKET_VERSION=6.2
     - RACKET_VERSION=6.3
     - RACKET_VERSION=6.4
-    - RACKET_VERSION=6.5
-    - RACKET_VERSION=6.6
     - RACKET_VERSION=HEAD
 
 # You may want to test against certain versions of Racket, without
@@ -38,7 +36,7 @@ script:
  # don't rely on package server
  - travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-lib
  - raco test -p beautiful-racket-lib
- - travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=brag
+ - travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-ragg
- - raco test -p brag
+ - raco test -p beautiful-racket-ragg
  - travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket
  - raco test -p beautiful-racket

README.md

@@ -5,14 +5,11 @@ Resources for the upcoming “Beautiful Racket” book, including:
 
 * `#lang br` teaching language
  
-* `#lang brag` parser generator language (a fork of Danny Yoo's [ragg](http://github.com/jbclements/ragg))
- 
 * supporting modules
 
 * sample languages
 
 
-
 Installation:
 
 `raco pkg install beautiful-racket`

beautiful-racket-lib/br/cond.rkt

@@ -1,36 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base br/syntax)
-         br/define)
-(provide (all-defined-out))
-
-(define-macro (until COND EXPR ...)
-  #'(let loop ()
-      (unless COND
-        EXPR ...
-        (loop))))
-
-(define-macro (while COND EXPR ...)
-  #'(let loop ()
-      (when COND
-        EXPR ...
-        (loop))))
-
-(define-macro (forever . EXPRS)
-  ;; todo: would be better with a syntax parameter
-  (with-pattern
-   ([stop (datum->syntax #'EXPRS 'stop)])
-   #'(let/ec stop
-       (while #t
-              . EXPRS))))
-
-(module+ test
-  (require rackunit)
-  (check-equal? (let ([x 5])
-                  (until (zero? x)
-                         (set! x (- x 1)))
-                  x) 0)
-  (check-equal? (let ([x 5])
-                  (while (positive? x)
-                         (set! x (- x 1)))
-                  x) 0))
-

beautiful-racket-lib/br/conditional.rkt

@@ -0,0 +1,15 @@
+#lang racket/base
+(require (for-syntax racket/base))
+(provide (all-defined-out))
+
+(define-syntax-rule (until cond expr ...)
+  (let loop ()
+    (unless cond
+      expr ...
+      (loop))))
+
+(define-syntax-rule (while cond expr ...)
+  (let loop ()
+    (when cond
+      expr ...
+      (loop))))

beautiful-racket-lib/br/datum.rkt

@@ -1,29 +1,31 @@
 #lang racket/base
 (require (for-syntax racket/base br/syntax) br/define)
-(provide (except-out (all-defined-out) string->datum))
+(provide (all-defined-out))
 
 ;; read "foo bar" the same way as "(foo bar)" 
-;; otherwise "bar" is dropped, which is too astonishing
+;; other "bar" is dropped, which is too astonishing
 (define (string->datum str)
-  (if (positive? (string-length str))
+  (let ([result (read (open-input-string (format "(~a)" str)))])
-      (let ([result (read (open-input-string (format "(~a)" str)))])
+    (if (= (length result) 1)
-        (if (= (length result) 1)
+        (car result)
-            (car result)
+        result)))
-            result))
-      (void)))
 
-(define (datum? x)
+#;(define-syntax format-datum
-  (or (list? x) (symbol? x)))
+    (λ(stx)
+      (syntax-case stx (quote datum)
+        [(_ (quote <datum-template>) <arg> ...)
+         #'(format-datum (datum <datum-template>) <arg> ...)]
+        [(_ (datum datum-template) <arg> ...)
+         (syntax-let ([#'format-string (format "~a" (syntax->datum #'datum-template))])
+                     #'(string->datum (apply format format-string (map (λ(arg) (if (syntax? arg)
+                                                                                   (syntax->datum arg)
+                                                                                   arg)) (list <arg> ...)))))])))
 
 (define (format-datum datum-template . args)
   (string->datum (apply format (format "~a" datum-template) (map (λ(arg) (if (syntax? arg)
                                                                              (syntax->datum arg)
                                                                              arg)) args))))
 
-;; todo: rephrase errors from `format` or `map` in terms of `format-datums`
-(define (format-datums datum-template . argss)
-  (apply map (λ args (apply format-datum datum-template args)) argss))
-
 (module+ test
   (require rackunit syntax/datum)
   (check-equal? (string->datum "foo") 'foo)
@@ -34,5 +36,4 @@
   (check-equal? (format-datum '(~a-bar-~a) #'foo #'zam) '(foo-bar-zam))
   (check-equal? (format-datum (datum (~a-bar-~a)) "foo" "zam") '(foo-bar-zam))
   (check-equal? (format-datum '~a "foo") 'foo)
-  (check-equal? (format-datum (datum ~a) "foo") 'foo)
+  (check-equal? (format-datum (datum ~a) "foo") 'foo))
-  (check-equal? (format-datums '(put ~a) '("foo" "zam")) '((put foo) (put zam))))

beautiful-racket-lib/br/debug.rkt

@@ -1,26 +1,17 @@
 #lang racket/base
-(require (for-syntax racket/base br/syntax)
+(require (for-syntax racket/base racket/syntax))
-         br/define)
 (provide (all-defined-out))
 
-(define-macro-cases report
+(define-syntax (report stx)
-  [(_ EXPR) #'(report EXPR EXPR)]
+  (syntax-case stx ()
-  [(_ EXPR NAME)
+    [(_ expr) #'(report expr expr)]
-   #'(let ([expr-result EXPR]) 
+    [(_ expr name)
-       (eprintf "~a = ~v\n" 'NAME expr-result)
+     #'(let ([expr-result expr]) 
-       expr-result)])
+         (eprintf "~a = ~v\n" 'name expr-result)
+         expr-result)]))
 
-(define-macro-cases report-datum
+(define-syntax-rule (define-multi-version multi-name name)
-  [(_ STX-EXPR)
+  (define-syntax-rule (multi-name x (... ...))
-   (with-pattern ([datum (syntax->datum #'STX-EXPR)])
+    (begin (name x) (... ...))))
-     #'(report-datum STX-EXPR datum))]
-  [(_ STX-EXPR NAME)
-   #'(let () 
-       (eprintf "~a = ~v\n" 'NAME (syntax->datum STX-EXPR))
-       STX-EXPR)])
-
-(define-macro (define-multi-version MULTI-NAME NAME)
-  #'(define-macro (MULTI-NAME X (... ...))
-      #'(begin (NAME X) (... ...))))
 
 (define-multi-version report* report)

beautiful-racket-lib/br/define.rkt

@@ -1,262 +1,284 @@
 #lang racket/base
-(require
+(require (for-syntax racket/list racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context racket/string) sugar/define)
-  racket/function
+(provide (all-defined-out))
-  (for-syntax racket/base
-              syntax/parse
-              br/private/syntax-flatten
-              syntax/define))
-(provide (all-defined-out)
-         (for-syntax with-shared-id))
 
-(module+ test
+;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br
-  (require rackunit))
 
+(define-for-syntax (syntax-flatten stx)
+  (flatten
+   (let loop ([stx stx])
+     (define maybe-list (syntax->list stx))
+     (if maybe-list
+         (map loop maybe-list)
+         stx))))
 
-(define-syntax (define+provide stx)
+(define-for-syntax (generate-literals pats)
-  (with-syntax ([(id lambda-exp)
+  ;; generate literals for any symbols that are not ... or _ or _underscore-prefixed
-                 (let-values ([(id-stx body-exp-stx)
+  (define pattern-arg-prefixer "_")
-                               (normalize-definition stx (datum->syntax stx 'λ) #t #t)])
+  (for/list ([pat-arg (in-list (syntax-flatten pats))]
-                   (list id-stx body-exp-stx))])
+             #:when (let ([pat-datum (syntax->datum pat-arg)])
-    #'(begin
+                      (and (symbol? pat-datum)
-        (provide id)
+                           (not (member pat-datum '(... _ else))) ; exempted from literality
-        (define id lambda-exp))))
+                           (not (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer)))))
-
+            pat-arg))
 
+;; expose the caller context within br:define macros with syntax parameter
 (begin-for-syntax
-  (define (upcased-and-capitalized? str)
-    (and (equal? (string-upcase str) str)
-         (not (equal? (string-downcase (substring str 0 1)) (substring str 0 1)))))
-
-  (define (generate-literals pats)
-    ;; generate literals for any symbols that are not ... or _ 
-    (define pattern-arg-prefixer "_")
-    (for*/list ([pat-arg (in-list (syntax-flatten pats))]
-                [pat-datum (in-value (syntax->datum pat-arg))]
-                #:when (and (symbol? pat-datum)
-                            (not (member pat-datum '(... _))) ; exempted from literality
-                            (not (upcased-and-capitalized? (symbol->string pat-datum)))))
-               pat-arg)))
-
-(begin-for-syntax
-  ;; expose the caller context within br:define macros with syntax parameter
   (require (for-syntax racket/base) racket/stxparam)
-  (provide caller-stx)
+  (provide caller-stx shared-syntax)
-  (define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized))))
+  (define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized)))
+  (define-syntax-parameter shared-syntax (λ(stx) (error 'shared-syntax-not-parameterized))))
 
 
-(define-syntax (define-cases stx)
+(define-syntax (br:define-cases stx)
-  (syntax-parse stx
-    #:literals (syntax)
-    [(_ id:id)
-     (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'id))]
-    [(_ id:id [(_ . pat-args:expr) . body:expr] ...)
-     #'(define id
-         (case-lambda
-           [pat-args . body] ...
-           [rest-pat (apply raise-arity-error 'id (normalize-arity (map length '(pat-args ...))) rest-pat)]))]
-    [else (raise-syntax-error
-           'define-cases
-           "no matching case for calling pattern"
-           (syntax->datum stx))]))
-
-
-(module+ test
-  (define-cases f
-    [(_ arg) (add1 arg)]
-    [(_ arg1 arg2) (+ arg1 arg2)]
-    [(_ . any) 'boing])
-  (check-equal? (f 42) 43)
-  (check-equal? (f 42 5) 47)
-  (check-equal? (f 42 5 'zonk) 'boing)
-
-  (define-cases f-one-arg
-    [(_ arg) (add1 arg)])
-  (check-exn exn:fail:contract:arity? (λ _ (f-one-arg 1 2 3))))
-
-
-(define-syntax-rule (debug-define-macro (ID . PAT-ARGS) BODY)
-  (define-macro (ID . PAT-ARGS)
-    #`(begin
-        (for-each displayln
-                  (list
-                   (format "input pattern = #'~a" '#,'(ID . PAT-ARGS))
-                   (format "output pattern = #'~a" (cadr '#,'BODY))
-                   (format "invoked as = ~a" (syntax->datum #'(ID . PAT-ARGS)))
-                   (format "expanded as = ~a" '#,(syntax->datum BODY))
-                   (format "evaluated as = ~a" #,BODY)))
-        #,BODY)))
-
-
-(module+ test
-  (require rackunit racket/port)
-  (parameterize ([current-output-port (open-output-nowhere)])
-    (check-equal? (let ()
-                    (debug-define-macro (foo X Y Z)
-                                        #'(apply + (list X Y Z)))
-                    (foo 1 2 3)) 6)  
-    (check-equal? (let ()
-                    (debug-define-macro (foo X ...) #'(apply * (list X ...)))
-                    (foo 10 11 12)) 1320)))
-
-
-(begin-for-syntax
-  (begin-for-syntax
-    (require (for-syntax racket/base))
-    (define-syntax-rule (make-shared-syntax-macro caller-stx)
-      #'(syntax-rules stx
-          [(_ form)
-           #'(datum->syntax caller-stx (if (syntax? form)
-                                           (syntax-e form)
-                                           form))]))))
-
-(module+ test
-  (define-macro (dirty-maker ARG)
-    (with-syntax ([dirty-bar (datum->syntax caller-stx 'dirty-bar)])
-      #'(define dirty-bar (* ARG 2))))
-  (dirty-maker 42)
-  (check-equal? dirty-bar 84))
-
-
-(begin-for-syntax
-  (define-syntax-rule (with-shared-id (id ...) . body)
-    (with-syntax ([id (datum->syntax caller-stx 'id)] ...)
-      . body)))
-
-
-;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
-(begin-for-syntax
-  (require syntax/parse)
   (define-syntax-class syntaxed-id
-    #:literals (syntax quasisyntax)
+    #:literals (syntax)
     #:description "id in syntaxed form"
-    (pattern ([~or syntax quasisyntax] name:id)))
+    (pattern (syntax name:id)))
   
   (define-syntax-class syntaxed-thing
-    #:literals (syntax quasisyntax)
+    #:literals (syntax)
     #:description "some datum in syntaxed form"
-    (pattern ([~or syntax quasisyntax] thing:expr)))
+    (pattern (syntax thing:expr)))
   
-  (define-syntax-class else-clause
-    #:literals (else)
-    (pattern [else . body:expr]))
-
-  (define-syntax-class transformer-func
-    #:literals (lambda λ)
-    (pattern ([~or lambda λ] (arg:id) . body:expr))))
-
-
-(define-syntax (define-macro stx)
   (syntax-parse stx
-    [(_ id:id stxed-id:syntaxed-id)
+    #:literals (syntax)
-     #'(define-syntax id (make-rename-transformer stxed-id))]
-    [(_ id:id func:transformer-func)
-     #'(define-syntax id func)]
-    [(_ id:id func-id:id)
-     #'(define-syntax id func-id)]
-    [(_ id:id stxed-thing:syntaxed-thing) 
-     #'(define-macro id (λ (stx) stxed-thing))]
-    [(_ (id:id . patargs:expr) . body:expr)
-     #'(define-macro-cases id [(id . patargs) (begin . body)])]
-    [else (raise-syntax-error
-           'define-macro
-           "no matching case for calling pattern"
-           (syntax->datum stx))]))
     
+    ;; defective for syntax or function
+    [(_ top-id)
+     (raise-syntax-error 'define-cases "no cases given" (syntax->datum #'top-id))]
     
-(define-syntax (define-macro-cases stx)  
+    ;; defective for syntax
-  (syntax-parse stx
+    [(_ (sid:syntaxed-id . _) . _)  ; (define (#'f1 stx) expr ...)
-    [(_ id:id)
+     (raise-syntax-error 'define-cases "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
-     (raise-syntax-error 'define-macro-cases "no cases given" (syntax->datum #'id))]
+    
-    [(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...)
+    ;; syntax matcher
-     (raise-syntax-error 'define-macro-cases "`else` clause must be last" (syntax->datum #'id))]
+    [(_ top-id:syntaxed-id . patexprs)
-    [(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
+     ;; todo: rephrase this check as a syntax-parse pattern above
-     (with-syntax ([LITERALS (generate-literals #'(pat ...))])
+     (let ([all-but-last-pat-datums (map syntax->datum (syntax->list (syntax-case #'patexprs ()
-       #'(define-macro id
+                                                                       [((pat result) ... last-one) #'(pat ...)])))])
-           (λ (stx)
+       (when (member 'else all-but-last-pat-datums)
-             (define result
+         (raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name))))
-               (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
+     (with-syntax* ([((pat . result-exprs) ... else-result-exprs)
-                 (syntax-case stx LITERALS
+                     (syntax-case #'patexprs (syntax else)
-                   [pat . result-exprs] ...
+                       [(((syntax pat) result-expr) ... (else . else-result-exprs))
-                   else-clause)))
+                        #'((pat result-expr) ... else-result-exprs)]
-             (if (syntax? result)
+                       [(((syntax pat) result-expr) ...)
-                 result
+                        #'((pat result-expr) ... (list (raise-syntax-error 'define-cases (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'top-id.name))))])]
-                 (datum->syntax #'id result)))))]
+                    [LITERALS (generate-literals #'(pat ...))])
-    [(_ id:id pat-clause:expr ...) ; macro without `else` clause will reach this branch
+       #'(define-syntax top-id.name (λ (stx)
-     #'(define-macro-cases id
+                                      (define result
-         pat-clause ...
+                                        (syntax-case stx LITERALS
-         [else (raise-syntax-error
+                                          [pat (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
-                'id
+                                                 (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
-                "no matching case for calling pattern"
+                                                   . result-exprs))] ...
-                (syntax->datum caller-stx))])]
+                                          [else . else-result-exprs]))
-    [else (raise-syntax-error
+                                      (if (syntax? result)
-           'define-macro-cases
+                                          result
-           "no matching case for calling pattern"
+                                          (datum->syntax #'top-id.name result)))))]
-           (syntax->datum stx))]))
+    
+    ;; function matcher
+    [(_ top-id:id [(_ . pat-args) . body] ...)
+     #'(define top-id
+         (case-lambda
+           [pat-args . body] ...
+           [else (raise-syntax-error 'define-cases "no matching case for argument pattern" (object-name top-id))]))]))
 
 
 (module+ test
-  (define-macro plus (λ(stx) #'+))
+  (require rackunit)
-  (check-equal? (plus 42) +)
-  (define-macro plusser #'plus)
-  (check-equal? (plusser 42) +)
-  (check-equal? plusser +)
-  (define-macro (times [nested ARG]) #`(* ARG ARG))
-  (check-equal? (times [nested 10]) 100)
-  (define-macro timeser #'times)
-  (check-equal? (timeser [nested 12]) 144)
-  (define-macro fortytwo #`42)
-  (check-equal? fortytwo 42)
-  (check-equal? (let ()
-                  (define-macro (foo X)
-                    (with-syntax ([zam +])
-                      #'(zam X X))) (foo 42)) 84) 
-  (begin
-    (define-macro (redefine ID) #'(define ID 42))
-    (redefine zoombar)
-    (check-equal? zoombar 42))
-  
-  ;; use caller-stx parameter to introduce identifier unhygienically
-  (define-macro (zam ARG1 ARG2 ARG3)
-    (with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
-      #`(define dz 'got-dirty-zam)))
-  
-  (zam 'this 'that 42)
-  (check-equal? dirty-zam 'got-dirty-zam)
-  
-  (define-macro (add X) #'(+ X X))
-  (check-equal? (add 5) 10)
-  (define-macro-cases add-again [(_ X) #'(+ X X)])
-  (check-equal? (add-again 5) 10)
-  (define-macro-cases add-3rd [(_ X) #'(+ X X)])
-  (check-equal? (add-3rd 5) 10)
-  (define-macro add-4th #'add-3rd)
-  (check-equal? (add-4th 5) 10)
   (define foo-val 'got-foo-val)
   (define (foo-func) 'got-foo-func)
-  (define-macro-cases op
+  (br:define-cases #'op
-    [(_ "+") #''got-plus]
+                   [#'(_ "+") #''got-plus]
-    [(_ ARG) #''got-something-else]
+                   [#'(_ _ARG) #''got-something-else]
-    [(_) #'(foo-func)]
+                   [#'(_) #'(foo-func)]
-    [_ #'foo-val])
+                   [#'_ #'foo-val])
   
   (check-equal? (op "+") 'got-plus)
   (check-equal? (op 42) 'got-something-else)
   (check-equal? (op) 'got-foo-func)
   (check-equal? op 'got-foo-val)
   
-  (define-macro-cases elseop
+  (br:define-cases #'elseop
-    [(_ ARG) #''got-arg]
+                   [#'(_ _arg) #''got-arg]
-    [else #''got-else])
+                   [else #''got-else])
   
   (check-equal? (elseop "+") 'got-arg)
   (check-equal? (elseop "+" 42) 'got-else)
   
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases no-cases))))
+ (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases #'badelseop
+                                               [else #''got-else]
+                                               [#'(_ _arg) #''got-arg]))))
   
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(define-macro-cases badelseop
+  (br:define-cases f
-                                                    [else #''got-else]
+                   [(_ arg) (add1 arg)]
-                                                    [(_ _arg) #''got-arg]))))
+                   [(_ arg1 arg2) (+ arg1 arg2)])
   
-  (define-macro-cases no-else-macro
+  (check-equal? (f 42) 43)
-    [(_ ARG) #''got-arg])
+  (check-equal? (f 42 5) 47)
-  (check-exn exn:fail:syntax? (λ _ (expand-once #'(no-else-macro 'arg1 'arg2)))))
+  
+  (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define-cases (#'times stx stx2) #'*)))))
+
+
+
+
+(define-syntax (br:define stx)
+  
+  ;;todo: share syntax classes
+  
+  (define-syntax-class syntaxed-id
+    #:literals (syntax)
+    #:description "id in syntaxed form"
+    (pattern (syntax name:id)))
+  
+  (define-syntax-class syntaxed-thing
+    #:literals (syntax)
+    #:description "some datum in syntaxed form"
+    (pattern (syntax thing:expr)))
+  
+  (syntax-parse stx
+    #:literals (syntax)
+    
+    ;; syntax
+    [(_ (syntax (id . pat-args)) . body) ; (define #'(foo arg) #'(+ arg arg))
+     #'(br:define-cases (syntax id) [(syntax (_ . pat-args)) . body])]
+    
+    [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
+     #'(define-syntax sid.name (make-rename-transformer sid2))]
+    
+    [(_ (syntax id) (syntax thing)) ; (define #'f1 #'42)
+     #'(br:define-cases (syntax id) [#'_ (syntax thing)])]
+    
+    [(_ (sid:syntaxed-id stx-arg ...) . exprs)  ; (define (#'f1 stx) expr ...)
+     (raise-syntax-error 'define "definition of a syntax transformer must use lambda notation, because otherwise it's too easy to confuse the compile-time shape and the run-time shape" (syntax->datum #'sid.name))]
+    
+    [(_ sid:syntaxed-id (λ (stx-arg ...) . exprs)) ; (define #'f1 (λ(stx) expr ...)
+     #:fail-when (not (= (length (syntax->datum #'(stx-arg ...))) 1))
+     (raise-syntax-error 'define "did not get exactly one argument for macro" (syntax->datum #'(stx-arg ...)))
+     (with-syntax ([(first-stx-arg other ...) #'(stx-arg ...)])
+     #'(define-syntax (sid.name first-stx-arg) . exprs))]
+    
+    [(_ . args) #'(define . args)]))
+
+(module+ test
+  (require rackunit)
+  (br:define #'plus (λ(stx) #'+))
+  (check-equal? (plus 42) +)
+  (br:define #'plusser #'plus)
+  (check-equal? (plusser 42) +)
+  (check-equal? plusser +)
+  (br:define #'(times [nested _ARG]) #'(* _ARG _ARG))
+  (check-equal? (times [nested 10]) 100)
+  (br:define #'timeser #'times)
+  (check-equal? (timeser [nested 12]) 144)
+  (br:define #'fortytwo #'42)
+  (check-equal? fortytwo 42)
+  (check-equal? (let ()
+                  (br:define #'(foo _X)
+                             (with-syntax ([zam +])
+                               #'(zam _X _X))) (foo 42)) 84) 
+  (check-exn exn:fail:syntax? (λ _ (expand-once #'(br:define (#'times stx stx2) #'*))))
+  (begin
+    (br:define #'(redefine _id) #'(define _id 42))
+    (redefine zoombar)
+    (check-equal? zoombar 42))
+  
+  ;; use caller-stx parameter to introduce identifier unhygienically
+  (br:define #'(zam _arg1 _arg2 _arg3)
+             (with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
+               #`(define dz 'got-dirty-zam)))
+  
+  (zam 'this 'that 42)
+  (check-equal? dirty-zam 'got-dirty-zam))
+
+
+(define-syntax-rule (br:debug-define (syntax (id . pat-args)) body-exp)
+  (br:define #'(id . pat-args)
+             #`(begin
+                 (for-each displayln
+                           (list
+                            (format "input pattern = #'~a" '#,'(id . pat-args))
+                            (format "output pattern = #'~a" (cadr '#,'body-exp))
+                            (format "invoked as = ~a" (syntax->datum #'(id . pat-args)))
+                            (format "expanded as = ~a" '#,(syntax->datum body-exp))
+                            (format "evaluated as = ~a" #,body-exp)))
+                 #,body-exp)))
+
+
+(module+ test
+  (require rackunit racket/port)
+  (parameterize ([current-output-port (open-output-nowhere)])
+    (check-equal? (let ()
+                    (br:debug-define #'(foo _X _Y _Z)
+                                     #'(apply + (list _X _Y _Z)))
+                    (foo 1 2 3)) 6)  
+    (check-equal? (let ()
+                    (br:debug-define #'(foo _X ...) #'(apply * (list _X ...)))
+                    (foo 10 11 12)) 1320)))
+
+
+
+(define-syntax-rule (br:define+provide . args)
+  (define+provide . args))
+
+
+(define-for-syntax (expand-macro mac)
+  (syntax-disarm (local-expand mac 'expression #f) #f))
+
+
+(define-syntax (br:define-inverting stx)
+  (syntax-case stx (syntax)
+    [(_ (syntax (_id . _pat-args)) . _syntaxexprs)
+     #'(br:define-cases-inverting (syntax _id)
+                                  [(syntax (_ . _pat-args)) . _syntaxexprs])]))
+
+(begin-for-syntax
+  (begin-for-syntax
+    (require (for-syntax racket/base))
+    (define-syntax (make-shared-syntax-macro stx)
+      (syntax-case stx ()
+        [(_ caller-stx)
+         #'(λ(stx) (syntax-case stx ()
+                     [(_ form)
+                      #'(datum->syntax caller-stx (if (syntax? form)
+                                                      (syntax-e form)
+                                                      form))]))]))))
+
+(define-syntax (br:define-cases-inverting stx)
+  (syntax-case stx (syntax)
+    [(_ (syntax _id) [(syntax _patarg) . _bodyexprs] ...)
+     (with-syntax ([LITERALS (generate-literals #'(_patarg ...))])
+       #'(define-syntax (_id stx)
+           (syntax-case stx ()
+             [(_id . rest)
+              (let ([expanded-stx (with-syntax ([expanded-macros (map expand-macro (syntax->list #'rest))])
+                                  #'(_id . expanded-macros))])
+                (define result
+                  (syntax-case expanded-stx LITERALS
+                    [_patarg (syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
+                            (syntax-parameterize ([shared-syntax (make-shared-syntax-macro caller-stx)])
+                              . _bodyexprs))] ...
+                    [else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))]))
+                (if (syntax? result)
+                    result
+                    (datum->syntax #'_id result)))])))]))
+
+
+(module+ test
+  ;; an inverting macro expands its arguments.
+  ;; so `foo` does not get `(falsy a) (falsy b) (falsy c)` as arguments,
+  ;; but rather the result of their expansion, namely `((#f a) (#f b) (#f c))`
+  ;; and `tree` does not get `(foo (#f a) (#f b) (#f c))` as its first argument,
+  ;; but rather the result of its expansion, namely (a b c).
+  (br:define-inverting #'(tree (_id ...) _vals)
+                       #'(let ()
+                           (define-values (_id ...) _vals)
+                           (list _id ...)))
+  
+  (br:define-cases-inverting #'foo
+                             [#'(_ (#f _id) ...) #'(_id ...)])
+  
+  (define-syntax-rule (falsy id) (#f id))
+  
+  (check-equal? (tree (foo (falsy a) (falsy b) (falsy c)) (values 1 2 3)) '(1 2 3)))

beautiful-racket-lib/br/eopl.rkt

@@ -0,0 +1,97 @@
+#lang br
+(require racket/struct (for-syntax br/datum))
+(provide define-datatype cases occurs-free?)
+
+#;(begin
+    (struct lc-exp () #:transparent)
+    
+    (struct var-exp lc-exp (var) #:transparent
+      #:guard (λ(var name)
+                (unless (symbol? var)
+                  (error name (format "arg ~a not ~a" var 'symbol?)))
+                (values var)))
+    
+    (struct lambda-exp lc-exp (bound-var body) #:transparent
+      #:guard (λ(bound-var body name)
+                (unless (symbol? bound-var)
+                  (error name (format "arg ~a not ~a" bound-var 'symbol?)))
+                (unless (lc-exp? body)
+                  (error name (format "arg ~a not ~a" body 'lc-exp?)))
+                (values bound-var body)))
+    
+    (struct app-exp lc-exp (rator rand) #:transparent
+      #:guard (λ(rator rand name)
+                (unless (lc-exp? rator)
+                  (error name (format "arg ~a not ~a" rator 'lc-exp?)))
+                (unless (lc-exp? rand)
+                  (error name (format "arg ~a not ~a" rand 'lc-exp?)))
+                (values rator rand))))
+
+
+(define #'(define-datatype _base-type _base-type-predicate?
+            (_subtype [_field _field-predicate?] ...) ...)
+  #'(begin
+      (struct _base-type () #:transparent #:mutable)
+      (struct _subtype _base-type (_field ...) #:transparent #:mutable
+        #:guard (λ(_field ... name)
+                  (unless (_field-predicate? _field)
+                    (error name (format "arg ~a is not ~a" _field '_field-predicate?))) ...
+                  (values _field ...))) ...))
+
+
+(define-datatype lc-exp lc-exp?
+  (var-exp [var symbol?])
+  (lambda-exp [bound-var symbol?] [body lc-exp?])
+  (app-exp [rator lc-exp?] [rand lc-exp?]))
+
+
+#;(define (occurs-free? search-var exp)
+    (cond
+      [(var-exp? exp) (let ([var (var-exp-var exp)])
+                        (eqv? var  search-var))]
+      [(lambda-exp? exp) (let ([bound-var (lambda-exp-bound-var exp)]
+                               [body (lambda-exp-body exp)])
+                           (and (not (eqv? search-var bound-var))
+                                (occurs-free? search-var body)))]
+      [(app-exp? exp) (let ([rator (app-exp-rator exp)]
+                            [rand (app-exp-rand exp)])
+                        (or
+                         (occurs-free? search-var rator)
+                         (occurs-free? search-var rand)))]))
+
+(define-syntax (cases stx)
+  (syntax-case stx (else)
+    [(_ <base-type> <input-var>
+        [<subtype> (<positional-var> ...) <body> ...] ...
+        [else <else-body> ...])
+     (inject-syntax ([#'(<subtype?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))])
+                    #'(cond
+                        [(<subtype?> <input-var>) (match-let ([(list <positional-var> ...) (struct->list <input-var>)])
+                                                    <body> ...)] ...
+                                                                 [else <else-body> ...]))]
+    [(_ <base-type> <input-var>
+        <subtype-case> ...)
+     #'(cases <base-type> <input-var>
+         <subtype-case> ...
+         [else (void)])]))
+
+
+(define (occurs-free? search-var exp)
+  (cases lc-exp exp
+    [var-exp (var) (eqv? var search-var)]
+    [lambda-exp (bound-var body)
+                (and (not (eqv? search-var bound-var))
+                     (occurs-free? search-var body))]
+    [app-exp (rator rand)
+             (or
+              (occurs-free? search-var rator)
+              (occurs-free? search-var rand))]))
+
+
+(module+ test
+  (require rackunit)
+  (check-true (occurs-free? 'foo (var-exp 'foo)))
+  (check-false (occurs-free? 'foo (var-exp 'bar)))
+  (check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
+  (check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
+  (check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))

beautiful-racket-lib/br/experimental/eopl.rkt

@@ -1,73 +0,0 @@
-#lang br
-(require racket/struct (for-syntax br/datum))
-(provide define-datatype cases occurs-free?)
-
-(define-macro (define-datatype BASE-TYPE BASE-TYPE-PREDICATE?
-                (SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...)
-  #'(begin
-      (struct BASE-TYPE () #:transparent #:mutable)
-      (struct SUBTYPE BASE-TYPE (FIELD ...) #:transparent #:mutable
-        #:guard (λ(FIELD ... name)
-                  (unless (FIELD-PREDICATE? FIELD)
-                    (error name (format "arg ~a is not ~a" FIELD 'FIELD-PREDICATE?))) ...
-                  (values FIELD ...))) ...))
-
-
-(define-datatype lc-exp lc-exp?
-  (var-exp [var symbol?])
-  (lambda-exp [bound-var symbol?] [body lc-exp?])
-  (app-exp [rator lc-exp?] [rand lc-exp?]))
-
-
-#;(define-syntax (cases stx)
-    (syntax-case stx (else)
-      [(_ _base-type INPUT-VAR
-          [SUBTYPE (POSITIONAL-VAR ...) . _body] ...
-          [else . _else-body])
-       (inject-syntax ([#'(_subtype? ...) (suffix-id #'(SUBTYPE ...) "?")])
-                      #'(cond
-                          [(_subtype? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
-                                                   . _body)] ...
-                                                             [else . _else-body]))]
-      [(_ _base-type INPUT-VAR
-          SUBTYPE-CASE ...)
-       #'(cases _base-type INPUT-VAR
-           SUBTYPE-CASE ...
-           [else (void)])]))
-
-
-(define-macro-cases cases
-  [(_ BASE-TYPE INPUT-VAR
-      [SUBTYPE (POSITIONAL-VAR ...) . BODY] ...
-      [else . ELSE-BODY])
-   (with-syntax ([(SUBTYPE? ...) (suffix-id #'(SUBTYPE ...) "?")])
-     #'(cond
-         [(SUBTYPE? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
-                                 . BODY)] ...
-                                          [else . ELSE-BODY]))]
-  [(_ BASE-TYPE INPUT-VAR
-      SUBTYPE-CASE ...)
-   #'(cases BASE-TYPE INPUT-VAR
-       SUBTYPE-CASE ...
-       [else (void)])])
-
-
-(define (occurs-free? search-var exp)
-  (cases lc-exp exp
-    [var-exp (var) (eqv? var search-var)]
-    [lambda-exp (bound-var body)
-                (and (not (eqv? search-var bound-var))
-                     (occurs-free? search-var body))]
-    [app-exp (rator rand)
-             (or
-              (occurs-free? search-var rator)
-              (occurs-free? search-var rand))]))
-
-
-(module+ test
-  (require rackunit)
-  (check-true (occurs-free? 'foo (var-exp 'foo)))
-  (check-false (occurs-free? 'foo (var-exp 'bar)))
-  (check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
-  (check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
-  (check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))

beautiful-racket-lib/br/experimental/scope.rkt

@@ -1,127 +0,0 @@
-#lang racket/base
-(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
-(provide (all-defined-out))
-
-(define (->syntax x)
-  (if (syntax? x) x (datum->syntax #f x)))
-
-
-(define (context stx)
-  (hash-ref (syntax-debug-info stx) 'context))
-
-(define-syntax-rule (scopes stx)
-  (format "~a = ~a" 'stx
-          (cons (syntax->datum stx)
-                (for/list ([scope (in-list (context stx))])
-                          scope))))
-
-(define (syntax-find stx stx-or-datum)
-  (unless (syntax? stx)
-    (raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
-  (define datum
-    (cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
-          [(symbol? stx-or-datum) stx-or-datum]
-          [else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
-  (let/ec exit
-    (let loop ([so stx])
-      (cond
-        [(eq? (syntax->datum so) datum) (exit so)]
-        [(syntax->list so) => (curry map loop)]))))
-
-(define-syntax (define-scope stx)
-  (syntax-case stx ()
-    [(_ id)
-     #'(define-scope id ())]
-    [(_ id scope-ids)
-     (with-syntax ([id-sis (suffix-id #'id "-sis")]
-                   [add-id (prefix-id "add-" #'id)]
-                   [flip-id (prefix-id "flip-" #'id)]
-                   [id-binding-form (suffix-id #'id "-binding-form")]
-                   [define-id (prefix-id "define-" #'id)]
-                   [with-id-identifiers (infix-id "with-" #'id "-identifiers")]
-                   [let-id-syntax (infix-id "let-" #'id "-syntax")]
-                   [with-id-binding-form (infix-id "with-" #'id "-binding-form")]
-                   [remove-id (prefix-id "remove-" #'id)]
-                   [id? (suffix-id #'id "?")]
-                   [id* (suffix-id #'id "*")]
-                   [(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
-       #'(begin
-           (define id-sis
-             (let ([sis-in (list scope-id-sis ...)])
-               (if (pair? sis-in)
-                   (apply append sis-in)
-                   (list
-                    (let ([si (make-syntax-introducer #t)])
-                      (list (procedure-rename (curryr si 'add) 'add-id)
-                            (procedure-rename (curryr si 'flip) 'flip-id)
-                            (procedure-rename (curryr si 'remove) 'remove-id)))))))
-           (define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
-           (define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
-           (define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
-           (define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
-           (define (id-binding-form x) (syntax-local-introduce (id x)))
-           (define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
-           (define (id? x)
-             (and
-              (member (car (context (add-id (datum->syntax #f '_))))
-                      (context (->syntax x)))
-              #t))
-           (define-syntax-rule (with-id-identifiers (name (... ...)) . body)
-             (with-syntax ([name (id* 'name)] (... ...)) . body))
-           (define-syntax-rule (with-id-binding-form  (name (... ...)) . body)
-             (with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
-           (define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
-             (let-syntax ([pat (id* val)] (... ...)) . body))))]))
-
-(define (scopes-equal? stxl stxr)
-  ;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
-  (bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
-
-
-(module+ test
-  (require rackunit)
-  (define-scope red)
-  
-  (define stx (datum->syntax #f 'x))
-  
-  (define red-stx (add-red stx))
-  (define double-red-stx (add-red (add-red stx)))
-  
-  
-  (check-false (red? stx))
-  (check-true (red? red-stx))
-  (check-true (red? double-red-stx))
-  (check-false (scopes-equal? stx red-stx))
-  (check-true (scopes-equal? red-stx double-red-stx))
-  (check-false (scopes-equal? red-stx (remove-red double-red-stx)))
-  
-  
-  (define-scope blue) ; scope addition is commutative
-  (define blue-stx (blue stx))
-  (check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
-  (check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
-  
-  
-  (define-scope green) ; replace scopes at outer layer
-  (check-true (scopes-equal? (green red-stx) (green blue-stx)))
-  
-  
-  ;; replace scopes everywhere
-  (check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
-                             (car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
-  
-  ;; todo: test flipping
-  
-  
-  (define-scope purple (red blue))
-  
-  (check-true (purple? (add-purple stx)))
-  (check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
-
-
-(define-syntax (with-scopes stx)
-  (syntax-case stx (syntax)
-    [(_ (scope-id) (syntax expr))
-     (with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
-       #'(add-scope-id expr))]))
-

beautiful-racket-lib/br/get-info.rkt

@@ -1,19 +0,0 @@
-#lang racket
-(provide (all-defined-out))
-
-(require racket/class)
-(define (indenter t pos)
-  (with-handlers ([exn:fail? (λ(exn) #f)]) ; this function won't work until gui-lib 1.26
-    (send t compute-racket-amount-to-indent pos (λ(x)
-                                                  (case x
-                                                    [("with-pattern" "with-shared-id") 'lambda]
-                                                    [("define-macro") 'define]
-                                                    [else #f])))))
-
-(define (br-get-info key default default-filter)
-  (case key
-    #;[(color-lexer)
-       (dynamic-require 'syntax-color/default-lexer 'default-lexer)]
-    [(drracket:indentation) indenter]
-    [else
-     (default-filter key default)]))

beautiful-racket-lib/br/main.rkt

@@ -1,22 +1,26 @@
 #lang racket/base
 (require racket/provide racket/list racket/string racket/format racket/match racket/port
-         br/define br/syntax br/datum br/debug br/cond racket/function
+         br/define br/syntax br/datum br/debug br/conditional
-         (for-syntax racket/base racket/syntax br/syntax br/debug br/define))
+         (for-syntax racket/base racket/syntax br/syntax br/define))
-(provide (all-from-out racket/base)
+(provide (except-out (all-from-out racket/base) define)
          (all-from-out racket/list racket/string racket/format racket/match racket/port
-                       br/syntax br/datum br/debug br/cond racket/function br/define)
+                       br/syntax br/datum br/debug br/conditional)
-         (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug))
+         (for-syntax (all-from-out racket/base racket/syntax br/syntax))
-         (for-syntax caller-stx with-shared-id)) ; from br/define
+         (for-syntax caller-stx shared-syntax) ; from br/define
+         (filtered-out
+          (λ (name)
+            (let ([pat (regexp "^br:")])
+              (and (regexp-match? pat name)
+                   (regexp-replace pat name ""))))
+          (combine-out (all-from-out br/define))))
 
 ;; todo: activate at-exp reader by default
 
-(provide evaluate)
+(define (remove-blank-lines strs)
-(define-macro (evaluate DATUM)
+  (filter (λ(str) (regexp-match #px"\\S" str)) strs))
-  #'(begin
+
-      (define-namespace-anchor nsa)
+(provide remove-blank-lines)
-      (eval DATUM (namespace-anchor->namespace nsa))))
+
 
 (module reader syntax/module-reader
-  #:language 'br
+  #:language 'br)
-  #:info br-get-info
-  (require br/get-info))

beautiful-racket-lib/br/private/syntax-flatten.rkt

@@ -1,12 +0,0 @@
-#lang racket/base
-(require racket/list)
-(provide (all-defined-out))
-
-(define (syntax-flatten stx)
-  (flatten
-   (let loop ([stx stx])
-     (let* ([stx-unwrapped (syntax-e stx)]
-            [maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))])
-       (if maybe-pair
-           (map loop maybe-pair)
-           stx)))))

beautiful-racket-lib/br/quicklang.rkt

@@ -1,31 +0,0 @@
-#lang br
-(require (for-syntax racket/list sugar/debug))
-(provide (except-out (all-from-out br) #%module-begin)
-         (rename-out [quicklang-mb #%module-begin]))
-
-(define-macro (quicklang-mb . EXPRS)
-  (define-values
-    (kw-pairs other-exprs)
-    (let loop ([kw-pairs null][exprs (syntax->list #'EXPRS)])
-      (if (and (pair? exprs) (keyword? (syntax-e (car exprs))))
-          (loop (cons (cons (string->symbol (keyword->string (syntax-e (car exprs))))
-                            (cadr exprs)) ; leave val in stx form so local binding is preserved
-                      kw-pairs)
-                (cddr exprs))
-          (values kw-pairs exprs))))
-  (define reserved-keywords '(provide))
-  (define (reserved? kw-pair) (memq (car kw-pair) reserved-keywords))
-  (define-values (reserved-kwpairs other-kwpairs) (partition reserved? kw-pairs))
-  (with-pattern ([((KW . VAL) ...) other-kwpairs]
-                 [(PROVIDED-ID ...) (or (assq 'provide reserved-kwpairs) null)])
-    #`(#%module-begin
-       (provide PROVIDED-ID ...)
-       (provide (rename-out [VAL KW]) ...)
-       (provide #%top #%app #%datum #%top-interaction)
-       . #,(datum->syntax #'EXPRS other-exprs #'EXPRS))))
-
-
-(module reader syntax/module-reader
-  #:language 'br/quicklang
-  #:info br-get-info
-  (require br/get-info))

beautiful-racket-lib/br/reader-utils.rkt

@@ -1,41 +1,43 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
+(require (for-syntax racket/base racket/syntax) syntax/strip-context)
 (provide define-read-and-read-syntax)
 
 ;; `define-read-functions` simplifies support for the standard reading API,
 ;; which asks for `read` and `read-syntax`.
 ;; in general, `read` is just the datum from the result of `read-syntax`.
 
-(define-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
+(define-syntax (define-read-and-read-syntax calling-site-stx)
-  (let ([internal-prefix (gensym)])
+  (syntax-case calling-site-stx ()
-    (with-syntax ([READ (datum->syntax caller-stx 'read)]
+    [(_ (PATH PORT) BODY ...)
-                  [READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
+     (let ([internal-prefix (gensym)])
-                  ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
+       (with-syntax ([READ (datum->syntax calling-site-stx 'read)]
-                  [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
+                     [READ-SYNTAX (datum->syntax calling-site-stx 'read-syntax)]
-                  [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
+                     ;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
-      #'(begin           
+                     [INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
-          (provide (rename-out [INTERNAL-READ READ]
+                     [INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
-                               [INTERNAL-READ-SYNTAX READ-SYNTAX]))
+         #'(begin           
-          (define (calling-site-function PATH PORT)
+             (provide (rename-out [INTERNAL-READ READ]
-            BODY ...) ; don't care whether this produces datum or syntax
+                                  [INTERNAL-READ-SYNTAX READ-SYNTAX]))
+             (define (calling-site-function PATH PORT)
+               BODY ...) ; don't care whether this produces datum or syntax
              
-          (define INTERNAL-READ-SYNTAX
+             (define INTERNAL-READ-SYNTAX
-            (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
+               (procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
-                                ;; because `read-syntax` must produce syntax
+                                   ;; because `read-syntax` must produce syntax
-                                ;; coerce a datum result to syntax if needed (à la `with-syntax`)
+                                   ;; coerce a datum result to syntax if needed (à la `with-syntax`)
-                                (define result-syntax (let ([output (calling-site-function path port)])
+                                   (define result-syntax (let ([output (calling-site-function path port)])
-                                                        (if (syntax? output)
+                                                           (if (syntax? output)
-                                                            output 
+                                                               output 
-                                                            (datum->syntax #f output))))
+                                                               (datum->syntax #f output))))
-                                ;; because `read-syntax` must produce syntax without context
+                                   ;; because `read-syntax` must produce syntax without context
-                                ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
+                                   ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
-                                ;; "a `read-syntax` function should return a syntax object with no lexical context"
+                                   ;; "a `read-syntax` function should return a syntax object with no lexical context"
-                                (strip-context result-syntax)) 'READ-SYNTAX)) 
+                                   (strip-context result-syntax)) 'READ-SYNTAX)) 
              
-          (define INTERNAL-READ
+             (define INTERNAL-READ
-            (procedure-rename (λ (port)
+               (procedure-rename (λ (port)
-                                ; because `read` must produce a datum
+                                   ; because `read` must produce a datum
-                                (let ([output (calling-site-function #f port)])
+                                   (let ([output (calling-site-function #f port)])
-                                  (if (syntax? output)
+                                     (if (syntax? output)
-                                      (syntax->datum output)
+                                         (syntax->datum output)
-                                      output))) 'READ))))))
+                                         output))) 'READ)))))]))

beautiful-racket-lib/br/scribblings/br.scrbl

@@ -1,417 +1,65 @@
 #lang scribble/manual
-@(require (for-label racket/base racket/contract br))
+@(require (for-label br/conditional))
-
-@(require scribble/eval)
-
-@(define my-eval (make-base-eval))
-@(my-eval `(require br racket/stxparam))
-
 
 @title[#:style 'toc]{Beautiful Racket}
 
 @author[(author+email "Matthew Butterick" "mb@mbtype.com")]
 
 
-
+Beautiful Racket @link["http://beautifulracket.com"]{is a book} about making programming languages with Racket.
-@link["http://beautifulracket.com"]{@italic{Beautiful Racket}} is a book about making programming languages with Racket.
 
 This library provides the @tt{#lang br} teaching language used in the book, as well as supporting modules that can be used in other programs.
 
-This library is designed to smooth over some of the small idiosyncrasies and inconsistencies in Racket, so that those new to Racket are more likely to say ``ah, that makes sense'' rather than ``huh? what?''
 
-@;{
+@;defmodulelang[br]
-@section{The @tt{br} language(s)}
 
-@defmodulelang[br]
+@tt{#lang br} is a teaching language designed to smooth over some of the small idiosyncrasies and inconsistencies in Racket, so that those new to Racket will say ``ah, that makes sense'' rather than ``huh? what?'' @tt{#lang br} is not meant to hide the true nature of Racket, but rather defer certain parts of the learning curve.
-
-
-@defmodulelang[br/quicklang]
-}
 
+To that end, this documentation not only explains the functions and forms in the Beautiful Racket library, but also how they depart from traditional or idiomatic Racket. (BTW ``Beautiful Racket'' is the name of the book, not an implication that the rest of Racket is less than beautiful. It is! But one thing at a time.)
 
 @section{Conditionals}
 
-@defmodule[br/cond]
+@defmodule[br/conditional]
 
-@defform[(while cond body ...)]{
+@defform[(while cond body ...)]
-Loop over @racket[body] as long as @racket[cond] is not @racket[#f]. If @racket[cond] starts out @racket[#f], @racket[body] is never evaluated.
+Loop over @racket[_body] expressions as long as @racket[_cond] is not @racket[#f]. If @racket[_cond] starts out @racket[#f], @racket[_body] expressions are not evaluated.
 
-@examples[#:eval my-eval
+@defform[(until cond body ...)]
-(let ([x 42])
+Loop over @racket[_body] expressions until @racket[_cond] is not @racket[#f]. If @racket[_cond] starts out @racket[#f], @racket[_body] expressions are not evaluated.
-  (while (positive? x)
-         (set! x (- x 1)))
-  x)
-(let ([x 42])
-  (while (negative? x)
-         (unleash-zombie-army))
-  x)
-]
-}
 
-@defform[(until cond body ...)]{
-Loop over @racket[body] until @racket[cond] is not @racket[#f]. If @racket[cond] starts out not @racket[#f], @racket[body] is never evaluated.
-
-@examples[#:eval my-eval
-(let ([x 42])
-  (until (zero? x)
-         (set! x (- x 1)))
-  x)
-(let ([x 42])
-  (until (= 42 x)
-         (destroy-galaxy))
-  x)
-]
-}
 
 @section{Datums}
 
 @defmodule[br/datum]
 
-A @defterm{datum} is a literal representation of a single unit of Racket code, also known as an @defterm{S-expression}. Unlike a string, a datum preserves the internal structure of the S-expression. Meaning, if the S-expression is a single value, or list-shaped, or tree-shaped, so is its corresponding datum. 
-
-Datums are made with @racket[quote] or its equivalent notation, the @litchar{'} prefix (see @secref["quote" #:doc '(lib "scribblings/guide/guide.scrbl")]).
-
-When I use ``datum'' in its specific Racket sense, I use ``datums'' as its plural rather than ``data'' because that term has an existing, more generic meaning. 
-
 @defproc[
 (format-datum
-[datum-form (or/c list? symbol?)]
+[datum-template symbol?]
-[val any/c?] ...)
+[arg any/c?] ...)
-(or/c list? symbol?)]{
+datum?]
-Similar to @racket[format], but the template @racket[datum-form] is a datum, rather than a string, and the function returns a datum, rather than a string. Otherwise, the same formatting escapes can be used in the template (see @racket[fprintf]).
+tk
-
-Two special cases. First, a string that describes a list of datums is parenthesized so the result is a single datum. Second, an empty string returns @racket[void] (not @racket[#f], because that's a legitimate datum).
-
-@examples[#:eval my-eval
-(format-datum '42)
-(format-datum '~a "foo")
-(format-datum '(~a ~a) "foo" 42)
-(format-datum '~a "foo bar zam")
-(void? (format-datum '~a ""))
-(format-datum '~a #f)
-]
-}
-
-@defproc[
-(format-datums
-[datum-form (or/c list? symbol?)]
-[vals (listof any/c?)] ...)
-(listof (or/c list? symbol?))]{
-Like @racket[format-datum], but applies @racket[datum-form] to the lists of @racket[vals] in similar way to @racket[map], where values for the format string are taken from the lists of @racket[vals] in parallel. This means that a) @racket[datum-form] must accept as many arguments as there are lists of @racket[vals], and b) the lists of @racket[vals] must all have the same number of items.
-
-@examples[#:eval my-eval
-(format-datums '~a '("foo" "bar" "zam"))
-(format-datums '(~a 42) '("foo" "bar" "zam"))
-(format-datums '(~a ~a) '("foo" "bar" "zam") '(42 43 44))
-(format-datums '42 '("foo" "bar" "zam"))
-(format-datums '(~a ~a) '("foo" "bar" "zam") '(42))
-]
-}
 
 
 @section{Debugging}
 
 @defmodule[br/debug]
 
-
+TK
-@defform*[[
-(report expr) 
-(report expr maybe-name)
-]]{
-Print the name and value of @racket[expr] to @racket[current-error-port], but also return the evaluated result of @racket[expr] as usual. This lets you see the value of an expression or variable at runtime without disrupting any of the surrounding code. Optionally, you can use @racket[maybe-name] to change the name shown in @racket[current-error-port].
-
-For instance, suppose you wanted to see how @racket[first-condition?] was being evaluted in this expression:
-
-@racketblock[
-(if (and (first-condition? x) (second-condition? x))
-  (one-thing)
-  (other-thing))]
-
-You can wrap it in @racket[report] and find out:
-
-@racketblock[
-(if (and (report (first-condition? x)) (second-condition? x))
-  (one-thing)
-  (other-thing))]
-
-This code will run the same way as before. But when it reaches @racket[first-condition?], you willl see in @racket[current-error-port]:
-
-@racketerror{(first-condition? x) = #t}
-
-You can also add standalone calls to @racket[report] as a debugging aid at points where the return value will be irrelevant, for instance:
-
-@racketblock[
-(report x x-before-function)
-(if (and (report (first-condition? x)) (second-condition? x))
-  (one-thing)
-  (other-thing))]
-
-@racketerror{x-before-function = 42
-@(linebreak)(first-condition? x) = #t}
-
-But be careful — in the example below, the result of the @racket[if] expression will be skipped in favor of the last expression, which will be the value of @racket[x]:
-
-@racketblock[
-(if (and (report (first-condition? x)) (second-condition? x))
-  (one-thing)
-  (other-thing))
-  (report x)]
-
-
-@defform[(report* expr ...)]
-Apply @racket[report] separately to each @racket[expr] in the list.
-
-
-@defform*[((report-datum stx-expr) (report-datum stx-expr maybe-name))]
-A variant of @racket[report] for use with @secref["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]. Rather than print the whole object (as @racket[report] would), @racket[report-datum] prints only the datum inside the syntax object, but the return value is the whole syntax object.
-}
 
 @section{Define}
 
 @defmodule[br/define]
 
-@defform[
+TK
-(define-cases id 
-  [pat body ...+] ...+)
-]
-Define a function that behaves differently depending on how many arguments are supplied (also known as @seclink["Evaluation_Order_and_Arity" #:doc '(lib "scribblings/guide/guide.scrbl")]{@italic{arity}}). Like @racket[cond], you can have any number of branches. Each branch starts with a @racket[_pat] that accepts a certain number of arguments. If the current invocation of the function matches the number of arguments in @racket[_pat], then the @racket[_body] on the right-hand side is evaluated. If there is no matching case, an arity error arises. (Derived from @racket[case-lambda], whose notation you might prefer.)
-
-@examples[#:eval my-eval
-(define-cases f
-  [(f arg1) (* arg1 arg1)]
-  [(f arg1 arg2) (* arg1 arg2)]
-  [(f arg1 arg2 arg3 arg4) (* arg1 arg2 arg3 arg4)])
-
-(f 4)
-(f 6 7)
-(f 1 2 3 4)
-(f "three" "arguments" "will-trigger-an-error")
-
-(define-cases f2
-  [(f2) "got zero args"]
-  [(f2 . args) (format "got ~a args" (length args))])
-
-(f2)
-(f2 6 7)
-(f2 1 2 3 4)
-(f2 "three" "arguments" "will-not-trigger-an-error-this-time")
-
-]
-
-
-@defform*[
-#:literals (syntax lambda stx)
-[
-(define-macro id (syntax other-id)) 
-(define-macro id (lambda (arg-id) result-expr ...+))
-(define-macro id transformer-id)
-(define-macro id (syntax result-expr)) 
-(define-macro (id pat-arg ...) expr ...+) 
-]]
-Create a macro using one of the subforms above, which are explained below:
-
-@specsubform[#:literals (define-macro syntax lambda stx) 
-(define-macro id (syntax other-id))]{
-If the first argument is an identifier @racket[id] and the second a syntaxed identifier that looks like @racket[(syntax other-id)], create a rename transformer, which is a fancy term for ``macro that replaces @racket[id] with @racket[other-id].'' (This subform is equivalent to @racket[make-rename-transformer].)
-
-Why do we need rename transformers? Because an ordinary macro operates on its whole calling expression (which it receives as input) like @racket[(macro-name this-arg that-arg . and-so-on)]. By contrast, a rename transformer operates only on the identifier itself (regardless of where that identifier appears in the code). It's like making one identifier into an alias for another identifier.
-
-Below, notice how the rename transformer, operating in the macro realm, approximates the behavior of a run-time assignment. 
-
-@examples[#:eval my-eval
-(define foo 'foo-value)
-(define bar foo)
-bar
-(define-macro zam-macro #'foo)
-zam-macro
-(define add +)
-(add 20 22)
-(define-macro sum-macro #'+)
-(sum-macro 20 22)
-]
-}
-
-
-@specsubform[#:literals (define-macro lambda stx) 
-(define-macro id (lambda (arg-id) result-expr ...+))]{
-If the first argument is an @racket[id] and the second a single-argument function, create a macro called @racket[id] that uses the function as a syntax transformer. This function must return a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object}, otherwise you'll trigger an error. Beyond that, the function can do whatever you like. (This subform is equivalent to @racket[define-syntax].)
-
-@examples[#:eval my-eval
-(define-macro nice-sum (lambda (stx) #'(+ 2 2)))
-nice-sum
-(define-macro not-nice (lambda (stx) '(+ 2 2)))
-not-nice
-]
-}
-
-@specsubform[#:literals (define-macro lambda stx) 
-(define-macro id transformer-id)]{
-Similar to the previous subform, but @racket[transformer-id] holds an existing transformer function. Note that @racket[transformer-id] needs to be visible during compile time (aka @italic{phase 1}), so use @racket[define-for-syntax] or equivalent.
-
-@examples[#:eval my-eval
-(define-for-syntax summer-compile-time (lambda (stx) #'(+ 2 2)))
-(define-macro nice-summer summer-compile-time)
-nice-summer
-(define summer-run-time (lambda (stx) #'(+ 2 2)))
-(define-macro not-nice-summer summer-run-time)
-]
-}
-
-@specsubform[#:literals (define-macro) 
-(define-macro id syntax-object)
-#:contracts ([syntax-object syntax?])]{
-If the first argument is an @racket[id] and the second a @racket[syntax-object], create a syntax transformer that returns @racket[syntax-object]. This is just alternate notation for the previous subform, wrapping @racket[syntax-object] inside a function body. The effect is to create a macro from @racket[id] that always returns @racket[syntax-object], regardless of how it's invoked. Not especially useful within programs. Mostly handy for making quick macros at the REPL.
-
-@examples[#:eval my-eval
-(define-macro bad-listener #'"what?")
-bad-listener
-(bad-listener)
-(bad-listener "hello")
-(bad-listener 1 2 3 4)
-]
-
-}
-
-@specsubform[#:literals (define-macro) 
-(define-macro (id pat-arg ...) result-expr ...+)]{
-If the first argument is a @seclink["stx-patterns" #:doc '(lib "scribblings/reference/reference.scrbl")]
-{syntax pattern} starting with @racket[id], then create a syntax transformer for this pattern using @racket[result-expr ...] as the return value. As usual, @racket[result-expr ...] needs to return a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object} or you'll get an error.
-
-The syntax-pattern notation is the same as @racket[syntax-case], with one key difference. If a @racket[pat-arg] has a @tt{CAPITALIZED-NAME}, it's treated as a named wildcard (meaning, it will match any expression in that position, and can be subsequently referred to by that name). Otherwise, @racket[pat-arg] is treated as a literal (meaning, it will only match the same expression). 
-
-For instance, the @racket[sandwich] macro below requires three arguments, and the third must be @racket[please], but the other two are wildcards:
-
-@examples[#:eval my-eval
-(define-macro (sandwich TOPPING FILLING please)
-  #'(format "I love ~a with ~a." 'FILLING 'TOPPING))
-
-(sandwich brie ham)
-(sandwich brie ham now)
-(sandwich brie ham please)
-(sandwich banana bacon please)
-
-]
-
-The ellipsis @racket[...] can be used with a wildcard to match a list of arguments. Please note: though a wildcard standing alone must match one argument, once you add an ellipsis, it's allowed to match zero:
-
-@examples[#:eval my-eval
-(define-macro (pizza TOPPING ...)
-  #'(string-join (cons "Waiter!"
-                       (list (format "More ~a!" 'TOPPING) ...))
-                 " "))
-
-(pizza mushroom)
-(pizza mushroom pepperoni)
-(pizza)
-]
-
-The capitalization requirement for a wildcard @racket[pat-arg] makes it easy to mix literals and wildcards in one pattern. But it also makes it easy to mistype a pattern and not get the wildcard you were expecting. Below, @racket[bad-squarer] doesn't work because @racket[any-number] is meant to be a wildcard. But it's not capitalized, so it's considered a literal, and it triggers an error:
-
-@examples[#:eval my-eval
-(define-macro (bad-squarer any-number)
-  #'(* any-number any-number))
-(bad-squarer +10i)
-]
-
-The error is cleared when the argument is capitalized, thus making it a wilcard:
-
-@examples[#:eval my-eval
-(define-macro (good-squarer ANY-NUMBER)
-  #'(* ANY-NUMBER ANY-NUMBER))
-(good-squarer +10i)
-]
-
-@;{You can use the special identifier @racket[caller-stx] — available only within the body of @racket[define-macro] — to access the original input argument to the macro.}
-
-@;{todo: fix this example. complains that caller-stx is unbound}
-@;{
-@examples[#:eval my-eval
-(require (for-syntax br))
-(define-macro (inspect ARG ...)
-  #`(displayln
-     (let ([calling-pattern '#,(syntax->datum caller-stx)])
-     (format "Called as ~a with ~a args"
-             calling-pattern
-             (length (cdr calling-pattern))))))
-
-(inspect)
-(inspect 42)
-(inspect "foo" "bar")
-(inspect #t #f #f #t)
-]
-}
-
-This subform of @racket[define-macro] is useful for macros that have one calling pattern. To make a macro with multiple calling patterns, see @racket[define-macro-cases].
-}
-
-
-@defform[
-(define-macro-cases id 
-  [pattern result-expr ...+] ...+) 
-]{
-Create a macro called @racket[id] with multiple branches, each with a @racket[pattern] on the left and @racket[result-expr]  on the right. The input to the macro is tested against each @racket[pattern]. If it matches, then @racket[result-expr] is evaluated.
-
-As with @racket[define-macro], wildcards in each syntax pattern must be @tt{CAPITALIZED}. Everything else is treated as a literal match, except for the ellipsis @racket[...] and the wildcard @racket[_].
-
-@examples[#:eval my-eval
-(define-macro-cases yogurt
-  [(yogurt) #'(displayln (format "No toppings? Really?"))]
-  [(yogurt TOPPING) 
-   #'(displayln (format "Sure, you can have ~a." 'TOPPING))]
-  [(yogurt TOPPING ANOTHER-TOPPING ... please)
-   #'(displayln (format "Since you asked nicely, you can have ~a toppings." 
-   (length '(TOPPING ANOTHER-TOPPING ...))))]
-  [(yogurt TOPPING ANOTHER-TOPPING ...)
-   #'(displayln (format "Whoa! Rude people only get one topping."))])
-
-(yogurt)
-(yogurt granola)
-(yogurt coconut almonds hot-fudge brownie-bites please)
-(yogurt coconut almonds)
-]
-
-}
 
 @section{Reader utilities}
 
 @defmodule[br/reader-utils]
 
-@defform[
+TK
-(define-read-and-read-syntax (path-id port-id) 
-  reader-result-expr ...+)
-]{
-For use within a language reader. Automatically @racket[define] and @racket[provide] the @racket[read] and @racket[read-syntax] functions needed for the reader's public interface. @racket[reader-result-expr] can return either a syntax object or a datum (which will be converted to a syntax object). 
 
-The generated @racket[read-syntax] function takes two arguments, a path and an input port. It returns a syntax object stripped of all bindings.
-
-The generated @racket[read] function takes one argument, an input port. It calls @racket[read-syntax] and converts the result to a datum.
-
-
-@examples[#:eval my-eval
-(module sample-reader racket/base
-  (require br/reader-utils racket/list)
-  (define-read-and-read-syntax (path port)
-    (add-between
-     (for/list ([datum (in-port read port)])
-              datum)
-     'whee)))
-
-(require (prefix-in sample: 'sample-reader))
-
-(define string-port (open-input-string "(+ 2 2) 'hello"))
-(sample:read-syntax 'no-path string-port)
-
-(define string-port-2 (open-input-string "(+ 2 2) 'hello"))
-(sample:read string-port-2)
-]
-
-
-}
-
-@;{
 @section{Syntax}
 
 @defmodule[br/syntax]
 
 TK
-}

beautiful-racket-lib/br/syntax.rkt

@@ -1,115 +1,34 @@
 #lang racket/base
-(require (for-syntax racket/base racket/syntax)
+(require (for-syntax racket/base syntax/parse) syntax/strip-context)
-         racket/list
+(provide (all-defined-out) (all-from-out syntax/strip-context))
-         racket/syntax
-         br/define
-         br/private/syntax-flatten)
-(provide (all-defined-out)
-         syntax-flatten)
-
-(module+ test
-  (require rackunit))
 
 
-(define-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
+(define-syntax (syntax-match stx)
-  #'(syntax-case STX-ARG ()
+  (syntax-case stx (syntax)
-      [PATTERN BODY ...] ...))
+    [(_ stx-arg [(syntax pattern) body ...] ...)
+     #'(syntax-case stx-arg ()
+         [pattern body ...] ...)]))
+
+(define-syntax (add-syntax stx)
+  ;; todo: permit mixing of two-arg and one-arg binding forms
+  ;; one-arg form allows you to inject an existing syntax object using its current name
+  (syntax-case stx (syntax)
+    [(_ ([(syntax sid) sid-stx] ...) body ...)
+     #'(with-syntax ([sid sid-stx] ...) body ...)]
+    ;; todo: limit `sid` to be an identifier
+    [(_ ([sid] ...) body ...)
+     #'(with-syntax ([sid sid] ...) body ...)]))
+
+(define-syntax syntax-let (make-rename-transformer #'add-syntax))
+
+(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
+
+(define-syntax (map-syntax stx)
+  (syntax-case stx ()
+    [(_ <proc> <arg> ...)
+     #'(map <proc> (if (and (syntax? <arg>) (list? (syntax-e <arg>)))
+                       (syntax->list <arg>)
+                       <arg>) ...)]))
 
 
-(define-macro-cases with-pattern
+#;(define-syntax syntax-variable (make-rename-transformer #'format-id))
-  [(_ () . BODY) #'(begin . BODY)]
-  [(_ ([SID SID-STX] STX ...) . BODY)
-   #'(with-syntax ([SID SID-STX])
-       (with-pattern (STX ...) . BODY))]
-  [(_ ([SID] STX ...) . BODY) ; standalone id
-   #'(with-pattern ([SID SID] STX ...) . BODY)]) ; convert to previous case
-
-
-(define (check-syntax-list-argument caller-name arg)
-  (cond
-    [(and (syntax? arg) (syntax->list arg))]
-    [(list? arg) arg]
-    [else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
-
-
-(define-macro (define-listy-macro MACRO-ID LIST-FUNC)
-  #'(define-macro (MACRO-ID STX-LIST LITERALS . MATCHERS)
-      #'(LIST-FUNC
-         (λ(stx-item)
-           (with-handlers ([exn:fail:syntax? (λ (exn) #f)])
-             (syntax-case stx-item LITERALS
-               . MATCHERS)))
-         (check-syntax-list-argument 'MACRO-ID STX-LIST))))
-
-(define-listy-macro syntax-case-partition partition)
-(define-listy-macro syntax-case-filter filter)
-(define-listy-macro syntax-case-map map)
-
-
-(define-macro (reformat-id FMT ID0 ID ...)
-  #'(format-id ID0 FMT ID0 ID ...))
-
-
-(define-macro (format-string FMT ID0 ID ...)
-  #'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
-
-
-(define-macro (->unsyntax X)
-  #'(if (syntax? X)
-        (syntax->datum X)
-        X))
-
-
-(define-macro (prefix-id PREFIX ... BASE-OR-BASES)
-  #'(let* ([bobs BASE-OR-BASES]
-           [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
-           [bases (if got-single?
-                      (list bobs)
-                      bobs)]
-           [result (syntax-case-map
-                    bases ()
-                    [base (format-id #'base "~a~a"
-                                     (string-append (format "~a" (->unsyntax PREFIX)) ...)
-                                     (syntax-e #'base))])])
-      (if got-single? (car result) result)))
-
-
-(define-macro (infix-id PREFIX BASE-OR-BASES SUFFIX ...)
-  #'(let* ([bobs BASE-OR-BASES]
-           [got-single? (and (not (list? bobs)) (not (syntax->list bobs)))]
-           [bases (if got-single?
-                      (list bobs)
-                      bobs)]
-           [result (syntax-case-map
-                    bases ()
-                    [base (format-id #'base "~a~a~a"
-                                     (->unsyntax PREFIX)
-                                     (syntax-e #'base)
-                                     (string-append (format "~a" (->unsyntax SUFFIX)) ...))])])
-      (if got-single? (car result) result)))
-
-
-(define-macro (suffix-id BASE-OR-BASES SUFFIX ...)
-  #'(infix-id "" BASE-OR-BASES SUFFIX ...))
-
-
-(define-macro-cases syntax-property*
-  [(_ STX 'PROP0) ; read one
-   #'(syntax-property STX 'PROP0)]
-  [(_ STX 'PROP0 'PROP ...) ; read multiple
-   #'(cons (syntax-property* STX 'PROP0)
-           (let ([result (syntax-property* STX 'PROP ...)])
-             (if (pair? result)
-                 result
-                 (list result))))]
-  [(_ STX ['PROP0 VAL0 . PRESERVED0]) ; write one
-   #'(syntax-property STX 'PROP0 VAL0 . PRESERVED0)]
-  [(_ STX ['PROP0 VAL0 . PRESERVED0] ['PROP VAL . PRESERVED] ...) ; write multiple
-   #'(syntax-property* (syntax-property STX 'PROP0 VAL0 . PRESERVED0) ['PROP VAL . PRESERVED] ...)])
-
-
-(module+ test
-  (define x (syntax-property* #'foo ['bar #t] ['zam 'boni]))
-  (check-false (syntax-property* x 'foo))
-  (check-true (syntax-property* x 'bar))
-  (check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))

beautiful-racket-lib/br/verbose-app.rkt

@@ -1,10 +0,0 @@
-#lang br
-(require (prefix-in br: (only-in br #%app)))
-(provide #%app)
-
-(define-macro (#%app APP ARG ...)
-  #'(let ()
-      (br:#%app displayln (br:#%app format "handling subexpressions in ~a" '(APP ARG ...)))
-      (define result (br:#%app APP ARG ...))
-      (br:#%app displayln (br:#%app format "evaluating ~a = ~a" '(APP ARG ...) result ))
-      result))

beautiful-racket-lib/info.rkt

@@ -2,7 +2,5 @@
 (define collection 'multi)
 
 (define version "0.01")
-(define deps '("base"
+(define deps '("base" "sugar"))
-               "sugar"
-               "gui-lib"))
 (define build-deps '("racket-doc" "rackunit-lib" "scribble-lib"))

beautiful-racket-ragg/br/ragg.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(module+ reader
+  (require "ragg/codegen/reader.rkt")
+  (provide (all-from-out "ragg/codegen/reader.rkt")))

beautiful-racket-ragg/br/ragg/br-ragg.scrbl

@@ -3,8 +3,8 @@
           racket/date
           file/md5
           (for-label racket
-                     brag/support
+                     br/ragg/support
-                     brag/examples/nested-word-list
+                     br/ragg/examples/nested-word-list
                      (only-in parser-tools/lex lexer-src-pos)
                      (only-in syntax/parse syntax-parse ~literal)))
 
@@ -26,29 +26,32 @@
 
 
 
-@title{brag: the Beautiful Racket AST Generator}
+@title{ragg: a Racket AST Generator Generator}
-@author["Danny Yoo (95%)" "Matthew Butterick (5%)"]
+@author+email["Danny Yoo" "dyoo@hashcollision.org"]
 
-@defmodulelang[brag]
 
-@section{Quick start}
+@section{Informal quickstart}
 
 @(define my-eval (make-base-eval))
-@(my-eval '(require brag/examples/nested-word-list 
+@(my-eval '(require br/ragg/examples/nested-word-list 
                           racket/list
                           racket/match))
 
-Suppose we're given the
+Salutations!  Let's consider the following scenario: say that we're given the
 following string:
 @racketblock["(radiant (humble))"]
 
 
-How would we turn this string into a structured value?  That is, how would we @emph{parse} it? (Let's also suppose we've never heard of @racket[read].)
+@margin-note{(... and pretend that we don't already know about the built-in
+@racket[read] function.)}  How do we go about turning this kind of string into a
+structured value?  That is, how would we @emph{parse} it?
 
-First, we need to consider the structure of the things we'd like to parse. The
+We need to first consider the shape of the things we'd like to parse.  The
-string above looks like a nested list of words. Good start.
+string above looks like a deeply nested list of words.  How might we describe
+this formally?  A convenient notation to describe the shape of these things is
+@link["http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form"]{Backus-Naur
+Form} (BNF).  So let's try to notate the structure of nested word lists in BNF.
 
-Second, how might we describe this formally — meaning, in a way that a computer could understand? A common notation to describe the structure of these things is @link["http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form"]{Backus-Naur Form} (BNF). So let's try to notate the structure of nested word lists in BNF.
 
 @nested[#:style 'code-inset]{
 @verbatim{
@@ -56,37 +59,48 @@ nested-word-list: WORD
                 | LEFT-PAREN nested-word-list* RIGHT-PAREN
 }}
 
-What we intend by this notation is this: @racket[nested-word-list] is either a @racket[WORD], or a parenthesized list of @racket[nested-word-list]s. We use the character @litchar{*} to represent zero or more repetitions of the previous thing. We treat the uppercased @racket[LEFT-PAREN], @racket[RIGHT-PAREN], and @racket[WORD] as placeholders for @emph{tokens} (a @tech{token} being the smallest meaningful item in the parsed string):
+What we intend by this notation is this: @racket[nested-word-list] is either an
+atomic @racket[WORD], or a parenthesized list of any number of
+@racket[nested-word-list]s.  We use the character @litchar{*} to represent zero
+or more repetitions of the previous thing, and we treat the uppercased
+@racket[LEFT-PAREN], @racket[RIGHT-PAREN], and @racket[WORD] as placeholders
+for atomic @emph{tokens}.
 
+@margin-note{See @secref{install-ragg} for instructions on installing
+@tt{ragg.}}
 Here are a few examples of tokens:
 @interaction[#:eval my-eval
-(require brag/support)
+(require br/ragg/support)
 (token 'LEFT-PAREN)
 (token 'WORD "crunchy" #:span 7)
 (token 'RIGHT-PAREN)]
 
-This BNF description is also known as a @deftech{grammar}. Just as it does in a natural language like English or French, a grammar describes something in terms of what elements can fit where.
 
-Have we made progress?  We have a valid grammar. But we're still missing a @emph{parser}: a function that can use that description to make structures out of a sequence of tokens.
+Have we made progress?  At this point, we only have a BNF description in hand,
+but we're still missing a @emph{parser}, something to take that description and
+use it to make structures out of a sequence of tokens.
 
-Meanwhile, it's clear that we don't yet have a valid program because there's no @litchar{#lang} line. Let's add one: put @litchar{#lang brag} at the top of the grammar, and save it as a file called @filepath{nested-word-list.rkt}.
+
+It's clear that we don't yet have a program because there's no @litchar{#lang}
+line.  We should add one.  Put @litchar{#lang br/ragg} at the top of the BNF
+description, and save it as a file called @filepath{nested-word-list.rkt}.
 
 @filebox["nested-word-list.rkt"]{
 @verbatim{
-#lang brag
+#lang br/ragg
 nested-word-list: WORD
                 | LEFT-PAREN nested-word-list* RIGHT-PAREN
 }}
 
-Now it's a proper program. But what does it do?
+Now it is a proper program.  But what does it do?
 
 @interaction[#:eval my-eval
 @eval:alts[(require "nested-word-list.rkt") (void)]
 parse
 ]
 
-It gives us a @racket[parse] function. Let's investigate what @racket[parse]
+It gives us a @racket[parse] function.  Let's investigate what @racket[parse]
-does. What happens if we pass it a sequence of tokens?
+does for us.  What happens if we pass it a sequence of tokens?
 
 @interaction[#:eval my-eval
              (define a-parsed-value
@@ -98,16 +112,15 @@ does. What happens if we pass it a sequence of tokens?
                             (token 'RIGHT-PAREN ")"))))
              a-parsed-value]
 
-Those who have messed around with macros will recognize this as a @seclink["stx-obj" #:doc '(lib "scribblings/guide/guide.scrbl")]{syntax object}.
+Wait... that looks suspiciously like a syntax object!
-
 @interaction[#:eval my-eval
 (syntax->datum a-parsed-value)
 ]
 
+
 That's @racket[(some [pig])], essentially.
 
-What happens if we pass our @racket[parse] function a bigger source of tokens?
+What happens if we pass it a more substantial source of tokens?
-
 @interaction[#:eval my-eval
 @code:comment{tokenize: string -> (sequenceof token-struct?)}
 @code:comment{Generate tokens from a string:}
@@ -122,12 +135,15 @@ What happens if we pass our @racket[parse] function a bigger source of tokens?
        (token 'WORD str)])))
 
 @code:comment{For example:}
-(define token-source (tokenize "(welcome (to (((brag)) ())))"))
+(define token-source (tokenize "(welcome (to (((ragg)) ())))"))
 (define v (parse token-source))
 (syntax->datum v)
 ]
 
-Welcome to @tt{brag}.
+Welcome to @tt{ragg}.
+
+
+
 
 
 
@@ -137,44 +153,69 @@ Welcome to @tt{brag}.
 
 @section{Introduction}
 
-@tt{brag} is a parser generator designed to be easy
+@tt{ragg} is a parsing framework for Racket with the design goal to be easy
-to use:
+to use.  It includes the following features:
-
 @itemize[
 
-@item{It provides a @litchar{#lang} for writing BNF grammars.
+@item{It provides a @litchar{#lang} for writing extended BNF grammars.
-A module written in @litchar{#lang brag} automatically generates a
+A module written in @litchar{#lang br/ragg} automatically generates a
-parser. The output of this parser tries to follow
+parser.  The output of this parser tries to follow
 @link["http://en.wikipedia.org/wiki/How_to_Design_Programs"]{HTDP}
-guidelines. The structure of the grammar informs the structure of the
+doctrine; the structure of the grammar informs the structure of the
 Racket syntax objects it generates.}
 
 @item{The language uses a few conventions to simplify the expression of
-grammars. The first rule in the grammar is assumed to be the
+grammars.  The first rule in the grammar is automatically assumed to be the
-starting production. Identifiers in @tt{UPPERCASE} are treated as
+starting production.  Identifiers in uppercase are assumed to represent
-terminal tokens. All other identifiers are treated as nonterminals.}
+terminal tokens, and are otherwise the names of nonterminals.}
 
-@item{Tokenizers can be developed independently of parsers.
+@item{Tokenizers can be developed completely independently of parsers.
-@tt{brag} takes a liberal view on tokens: they can be strings,
+@tt{ragg} takes a liberal view on tokens: they can be strings,
-symbols, or instances constructed with @racket[token]. Tokens can optionally provide source location, in which case a syntax object generated by the parser will too.}
+symbols, or instances constructed with @racket[token].  Furthermore,
+tokens can optionally provide location: if tokens provide location, the
+generated syntax objects will as well.}
 
-@item{The parser can usually handle ambiguous grammars.}
+@item{The underlying parser should be able to handle ambiguous grammars.}
 
-@item{It integrates with the rest of the Racket
+@item{It should integrate with the rest of the Racket
 @link["http://docs.racket-lang.org/guide/languages.html"]{language toolchain}.}
 
 ]
 
+@subsection[#:tag "install-ragg"]{Installation}
+
+@itemize[
+
+@item{@margin-note{At the time of this writing, Racket 5.3.2 is in
+@link["http://pre.racket-lang.org/"]{pre-release}.} If you are using a version
+of Racket > 5.3.1, then follow the instructions on the
+@link["https://plt-etc.byu.edu:9004/info/ragg"]{PLaneT2 page}.}
+
+
+
+@item{For those who are using Racket <= 5.3.1, you can download the following PLT package:
+
+@nested[#:style 'inset]{@link["ragg.plt"]{ragg.plt} [md5sum: @compute-md5sum["ragg.plt" "ab79038b40e510a5cf13363825c4aef4"]]
+     
+        Last updated: @lookup-date["ragg.plt" "Wednesday, January 16th, 2013"]
+        }
+
+Once downloaded, either use DrRacket's package installation features
+(@link["http://docs.racket-lang.org/drracket/Menus.html#(idx._(gentag._57._(lib._scribblings/drracket/drracket..scrbl)))"]{Install
+PLT File...} under DrRacket's File menu), or use the command line:
+@nested[#:style 'inset]{@tt{raco setup -A ragg.plt}}}
+
+]
+
 
 
 @subsection{Example: a small DSL for ASCII diagrams}
 
-@margin-note{This example is
+@margin-note{This is a
-@link["http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket"]{derived from a question}  on Stack Overflow.}  
+@link["http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket"]{restatement
-
+of a question on Stack Overflow}.}  To motivate @tt{ragg}'s design, let's look
-To understand @tt{brag}'s design, let's look
+at the following toy problem: we'd like to define a language for
-at a toy problem. We'd like to define a language for
+drawing simple ASCII diagrams.  We'd like to be able write something like this:
-drawing simple ASCII diagrams. So if we write something like this:
 
 @nested[#:style 'inset]{
 @verbatim|{
@@ -183,7 +224,7 @@ drawing simple ASCII diagrams. So if we write something like this:
 3 9 X;
 }|}
 
-It should generate the following picture:
+whose interpretation should generate the following picture:
 
 @nested[#:style 'inset]{
 @verbatim|{
@@ -204,10 +245,10 @@ XXXXXXXXX
 
 
 @subsection{Syntax and semantics}
-
+We're being very fast-and-loose with what we mean by the program above, so
-We're being somewhat casual with what we mean by the program above. Let's try to nail down some meanings. 
+let's try to nail down some meanings.  Each line of the program has a semicolon
-
+at the end, and describes the output of several @emph{rows} of the line
-Each line of the program has a semicolon at the end, and describes the output of several @emph{rows} of the line drawing. Let's look at two of the lines in the example:
+drawing.  Let's look at two of the lines in the example:
 
 @itemize[
 @item{@litchar{3 9 X;}: ``Repeat the following 3 times: print @racket["X"] nine times, followed by
@@ -218,17 +259,24 @@ followed by @racket["X"] three times, followed by @racket[" "] three times, foll
 ]
 
 Then each line consists of a @emph{repeat} number, followed by pairs of
-(number, character) @emph{chunks}. We'll assume here that the intent of the lowercased character @litchar{b} is to represent the printing of a 1-character whitespace @racket[" "], and for other uppercase letters to represent the printing of themselves.
+(number, character) @emph{chunks}.  We will
+assume here that the intent of the lowercased character @litchar{b} is to
+represent the printing of a 1-character whitespace @racket[" "], and for other
+uppercase letters to represent the printing of themselves.
 
-By understanding the pieces of each line, we can more easily capture that meaning in a grammar. Once we have each instruction of our ASCII DSL in a structured format, we should be able to parse it.
+Once we have a better idea of the pieces of each line, we have a better chance
+to capture that meaning in a formal notation.  Once we have each instruction in
+a structured format, we should be able to interpret it with a straighforward
+case analysis.
+
+Here is a first pass at expressing the structure of these line-drawing
+programs.
 
-Here's a first pass at expressing the structure of these line-drawing programs.
 
 @subsection{Parsing the concrete syntax}
-
 @filebox["simple-line-drawing.rkt"]{
 @verbatim|{
-#lang brag
+#lang br/ragg
 drawing: rows*
 rows: repeat chunk+ ";"
 repeat: INTEGER
@@ -236,21 +284,21 @@ chunk: INTEGER STRING
 }|
 }
 
-@margin-note{@secref{brag-syntax} describes @tt{brag}'s syntax in more detail.}
+@margin-note{@secref{ragg-syntax} describes @tt{ragg}'s syntax in more detail.}
-We write a @tt{brag} program as an BNF grammar, where patterns can be:
+We write a @tt{ragg} program as an extended BNF grammar, where patterns can be:
 @itemize[
 @item{the names of other rules (e.g. @racket[chunk])}
 @item{literal and symbolic token names (e.g. @racket[";"], @racket[INTEGER])}
 @item{quantified patterns (e.g. @litchar{+} to represent one-or-more repetitions)}
 ]
-The result of a @tt{brag} program is a module with a @racket[parse] function
+The result of a @tt{ragg} program is a module with a @racket[parse] function
 that can parse tokens and produce a syntax object as a result.
 
 Let's exercise this function:
 @interaction[#:eval my-eval
-(require brag/support)
+(require br/ragg/support)
 @eval:alts[(require "simple-line-drawing.rkt") 
-           (require brag/examples/simple-line-drawing)]
+           (require br/ragg/examples/simple-line-drawing)]
 (define stx
   (parse (list (token 'INTEGER 6) 
                (token 'INTEGER 2)
@@ -261,11 +309,17 @@ Let's exercise this function:
 (syntax->datum stx)
 ]
 
-A @emph{token} is the smallest meaningful element of a source program. Tokens can be  strings, symbols, or instances of the @racket[token] data structure. (Plus a few other special cases, which we'll discuss later.) Usually, a token holds a single character from the source program. But sometimes it makes sense to package a sequence of characters into a single token, if the sequence has an indivisible meaning.
+Tokens can either be: plain strings, symbols, or instances produced by the
+@racket[token] function.  (Plus a few more special cases, one in which we'll describe in a
+moment.)
 
-If possible, we also want to attach source location information to each token. Why? Because this informatino will be incorporated into the syntax objects produced by @racket[parse].
+Preferably, we want to attach each token with auxiliary source location
+information.  The more source location we can provide, the better, as the
+syntax objects produced by @racket[parse] will incorporate them.
 
-A parser often works in conjunction with a helper function called a @emph{lexer} that converts the raw code of the source program into tokens. The @racketmodname[parser-tools/lex] library can help us write a position-sensitive
+Let's write a helper function, a @emph{lexer}, to help us construct tokens more
+easily.  The Racket standard library comes with a module called
+@racketmodname[parser-tools/lex] which can help us write a position-sensitive
 tokenizer:
 
 @interaction[#:eval my-eval
@@ -301,19 +355,24 @@ tokenizer:
 ]
 
 
-Note also from this lexer example: 
+There are a few things to note from this lexer example: 
-
 @itemize[
 
-@item{@racket[parse] accepts as input either a sequence of tokens, or a
+@item{The @racket[parse] function can consume either sequences of tokens, or a
-function that produces tokens (which @racket[parse] will call repeatedly to get the next token).}
+function that produces tokens.  Both of these are considered sources of
+tokens.}
 
-@item{As an alternative to the basic @racket[token] structure, a token can also be an instance of the @racket[position-token] structure (also found in @racketmodname[parser-tools/lex]). In that case, the token will try to derive its position from that of the position-token.}
+@item{As a special case for acceptable tokens, a token can also be an instance
+of the @racket[position-token] structure of @racketmodname[parser-tools/lex],
+in which case the token will try to derive its position from that of the
+position-token.}
 
-@item{@racket[parse] will stop if it gets @racket[void] (or @racket['eof]) as a token.}
+@item{The @racket[parse] function will stop reading from a token source if any
+token is @racket[void].}
 
-@item{@racket[parse] will skip any token that has
+@item{The @racket[parse] function will skip over any token with the
-@racket[#:skip?] attribute set to @racket[#t]. For instance, tokens representing comments often use @racket[#:skip?].}
+@racket[#:skip?]  attribute. Elements such as whitespace and comments will
+often have @racket[#:skip?] set to @racket[#t].}
 
 ]
 
@@ -321,16 +380,16 @@ function that produces tokens (which @racket[parse] will call repeatedly to get
 @subsection{From parsing to interpretation}
 
 We now have a parser for programs written in this simple-line-drawing language.
-Our parser will return syntax objects:
+Our parser will give us back syntax objects:
-
 @interaction[#:eval my-eval
 (define parsed-program
   (parse (tokenize (open-input-string "3 9 X; 6 3 b 3 X 3 b; 3 9 X;"))))
 (syntax->datum parsed-program)
 ]
 
-Better still, these syntax objects will have a predictable
+Moreover, we know that these syntax objects have a regular, predictable
-structure that follows the grammar:
+structure.  Their structure follows the grammar, so we know we'll be looking at
+values of the form:
 
 @racketblock[
     (drawing (rows (repeat <number>)
@@ -342,14 +401,15 @@ where @racket[drawing], @racket[rows], @racket[repeat], and @racket[chunk]
 should be treated literally, and everything else will be numbers or strings.
 
 
-Still, these syntax-object values are just inert structures. How do we
+Still, these syntax object values are just inert structures.  How do we
-interpret them, and make them @emph{print}?  We claimed at the beginning of
+interpret them, and make them @emph{print}?  We did claim at the beginning of
-this section that these syntax objects should be easy to interpret. So let's do it.
+this section that these syntax objects should be fairly easy to case-analyze
+and interpret, so let's do it.
 
 @margin-note{This is a very quick-and-dirty treatment of @racket[syntax-parse].
 See the @racketmodname[syntax/parse] documentation for a gentler guide to its
 features.}  Racket provides a special form called @racket[syntax-parse] in the
-@racketmodname[syntax/parse] library. @racket[syntax-parse] lets us do a
+@racketmodname[syntax/parse] library.  @racket[syntax-parse] lets us do a
 structural case-analysis on syntax objects: we provide it a set of patterns to
 parse and actions to perform when those patterns match.
 
@@ -372,7 +432,7 @@ says @racket[#t] if it's the literal @racket[yes], and @racket[#f] otherwise:
 ]
 
 Here, we use @racket[~literal] to let @racket[syntax-parse] know that
-@racket[yes] should show up literally in the syntax object. The patterns can
+@racket[yes] should show up literally in the syntax object.  The patterns can
 also have some structure to them, such as:
 @racketblock[({~literal drawing} rows-stxs ...)]
 which matches on syntax objects that begin, literally, with @racket[drawing],
@@ -416,11 +476,11 @@ Let's define @racket[interpret-rows] now:
        (newline))]))]
 
 For a @racket[rows], we extract out the @racket[repeat-number] out of the
-syntax object and use it as the range of the @racket[for] loop. The inner loop
+syntax object and use it as the range of the @racket[for] loop.  The inner loop
 walks across each @racket[chunk-stx] and calls @racket[interpret-chunk] on it.
 
 
-Finally, we need to write a definition for @racket[interpret-chunk]. We want
+Finally, we need to write a definition for @racket[interpret-chunk].  We want
 it to extract out the @racket[chunk-size] and @racket[chunk-string] portions,
 and print to standard output:
 
@@ -493,7 +553,7 @@ Let's add one.
 
 @filebox["letter-i.rkt"]{
 @verbatim|{
-#lang brag/examples/simple-line-drawing
+#lang br/ragg/examples/simple-line-drawing
 3 9 X;
 6 3 b 3 X 3 b;
 3 9 X;
@@ -504,14 +564,14 @@ Now @filepath{letter-i.rkt} is a program.
 
 
 How does this work?  From the previous sections, we've seen how to take the
-contents of a file and interpret it. What we want to do now is teach Racket
+contents of a file and interpret it.  What we want to do now is teach Racket
-how to compile programs labeled with this @litchar{#lang} line. We'll do two
+how to compile programs labeled with this @litchar{#lang} line.  We'll do two
 things:
 
 @itemize[
-@item{Tell Racket to use the @tt{brag}-generated parser and lexer we defined
+@item{Tell Racket to use the @tt{ragg}-generated parser and lexer we defined
 earlier whenever it sees a program written with
-@litchar{#lang brag/examples/simple-line-drawing}.}
+@litchar{#lang br/ragg/examples/simple-line-drawing}.}
 
 @item{Define transformation rules for @racket[drawing], @racket[rows], and
       @racket[chunk] to rewrite these into standard Racket forms.}
@@ -519,30 +579,30 @@ earlier whenever it sees a program written with
 
 The second part, the writing of the transformation rules, will look very
 similar to the definitions we wrote for the interpreter, but the transformation
-will happen at compile-time. (We @emph{could} just resort to simply calling
+will happen at compile-time.  (We @emph{could} just resort to simply calling
 into the interpreter we just wrote up, but this section is meant to show that
 compilation is also viable.)
 
 
 We do the first part by defining a @emph{module reader}: a
 @link["http://docs.racket-lang.org/guide/syntax_module-reader.html"]{module
-reader} tells Racket how to parse and compile a file. Whenever Racket sees a
+reader} tells Racket how to parse and compile a file.  Whenever Racket sees a
 @litchar{#lang <name>}, it looks for a corresponding module reader in
 @filepath{<name>/lang/reader}.
 
 Here's the definition for
-@filepath{brag/examples/simple-line-drawing/lang/reader.rkt}:
+@filepath{br/ragg/examples/simple-line-drawing/lang/reader.rkt}:
 
-@filebox["brag/examples/simple-line-drawing/lang/reader.rkt"]{
+@filebox["br/ragg/examples/simple-line-drawing/lang/reader.rkt"]{
 @codeblock|{
 #lang s-exp syntax/module-reader
-brag/examples/simple-line-drawing/semantics
+br/ragg/examples/simple-line-drawing/semantics
 #:read my-read
 #:read-syntax my-read-syntax
 #:whole-body-readers? #t
 
-(require brag/examples/simple-line-drawing/lexer
+(require br/ragg/examples/simple-line-drawing/lexer
-         brag/examples/simple-line-drawing/grammar)
+         br/ragg/examples/simple-line-drawing/grammar)
 
 (define (my-read in)
   (syntax->datum (my-read-syntax #f in)))
@@ -553,8 +613,12 @@ brag/examples/simple-line-drawing/semantics
 }
 
 We use a helper module @racketmodname[syntax/module-reader], which provides
-utilities for creating a module reader. It uses the lexer and
+utilities for creating a module reader.  It uses the lexer and
-@tt{brag}-generated parser we defined earlier, and also tells Racket that it should compile the forms in the syntax
+@tt{ragg}-generated parser we defined earlier (saved into
+@link["http://hashcollision.org/ragg/examples/simple-line-drawing/lexer.rkt"]{lexer.rkt}
+and
+@link["http://hashcollision.org/ragg/examples/simple-line-drawing/grammar.rkt"]{grammar.rkt}
+modules), and also tells Racket that it should compile the forms in the syntax
 object using a module called @filepath{semantics.rkt}.
 
 @margin-note{For a systematic treatment on capturing the semantics of
@@ -563,7 +627,7 @@ Interpretation}.}
 
 Let's look into @filepath{semantics.rkt} and see what's involved in
 compilation:
-@filebox["brag/examples/simple-line-drawing/semantics.rkt"]{
+@filebox["br/ragg/examples/simple-line-drawing/semantics.rkt"]{
 @codeblock|{
 #lang racket/base
 (require (for-syntax racket/base syntax/parse))
@@ -619,7 +683,7 @@ compilation:
 The semantics hold definitions for @racket[compile-drawing],
 @racket[compile-rows], and @racket[compile-chunk], similar to what we had for
 interpretation with @racket[interpret-drawing], @racket[interpret-rows], and
-@racket[interpret-chunk]. However, compilation is not the same as
+@racket[interpret-chunk].  However, compilation is not the same as
 interpretation: each definition does not immediately execute the act of
 drawing, but rather returns a syntax object whose evaluation will do the actual
 work.
@@ -628,22 +692,22 @@ There are a few things to note:
 
 @itemize[
 
-@item{@tt{brag}'s native data structure is the syntax object because the
+@item{@tt{ragg}'s native data structure is the syntax object because the
 majority of Racket's language-processing infrastructure knows how to read and
 write this structured value.}
 
 
 @item{
 @margin-note{By the way, we can just as easily rewrite the semantics so that
-@racket[compile-rows] does explicitly call @racket[compile-chunk]. Often,
+@racket[compile-rows] does explicitly call @racket[compile-chunk].  Often,
 though, it's easier to write the transformation functions in this piecemeal way
 and depend on the Racket macro expansion system to do the rewriting as it
 encounters each of the forms.}
 Unlike in interpretation, @racket[compile-rows] doesn't
-compile each chunk by directly calling @racket[compile-chunk]. Rather, it
+compile each chunk by directly calling @racket[compile-chunk].  Rather, it
 depends on the Racket macro expander to call each @racket[compile-XXX] function
 as it encounters a @racket[drawing], @racket[rows], or @racket[chunk] in the
-parsed value. The three statements at the bottom of @filepath{semantics.rkt} inform
+parsed value.  The three statements at the bottom of @filepath{semantics.rkt} inform
 the macro expansion system to do this:
 
 @racketblock[
@@ -654,12 +718,12 @@ the macro expansion system to do this:
 ]
 
 
-Altogether, @tt{brag}'s intent is to be a parser generator generator for Racket
+Altogether, @tt{ragg}'s intent is to be a parser generator generator for Racket
-that's easy and fun to use. It's meant to fit naturally with the other tools
+that's easy and fun to use.  It's meant to fit naturally with the other tools
-in the Racket language toolchain. Hopefully, it will reduce the friction in
+in the Racket language toolchain.  Hopefully, it will reduce the friction in
 making new languages with alternative concrete syntaxes.
 
-The rest of this document describes the @tt{brag} language and the parsers it
+The rest of this document describes the @tt{ragg} language and the parsers it
 generates.
 
 
@@ -668,9 +732,9 @@ generates.
 
 @section{The language}
 
-@subsection[#:tag "brag-syntax"]{Syntax and terminology}
+@subsection[#:tag "ragg-syntax"]{Syntax and terminology}
-A program in the @tt{brag} language consists of the language line
+A program in the @tt{ragg} language consists of the language line
-@litchar{#lang brag}, followed by a collection of @tech{rule}s and
+@litchar{#lang br/ragg}, followed by a collection of @tech{rule}s and
 @tech{line comment}s.
 
 A @deftech{rule} is a sequence consisting of: a @tech{rule identifier}, a colon
@@ -681,7 +745,7 @@ A @deftech{rule identifier} is an @tech{identifier} that is not in upper case.
 A @deftech{token identifier} is an @tech{identifier} that is in upper case.
 
 An @deftech{identifier} is a character sequence of letters, numbers, and
-characters in @racket["-.!$%&/<=>?^_~@"]. It must not contain
+characters in @racket["-.!$%&/<=>?^_~@"].  It must not contain
 @litchar{*} or @litchar{+}, as those characters are used to denote
 quantification.
 
@@ -703,7 +767,7 @@ continues till the end of the line.
 For example, in the following program:
 @nested[#:style 'inset
 @verbatim|{
-#lang brag
+#lang br/ragg
 ;; A parser for a silly language
 sentence: verb optional-adjective object
 verb: greeting
@@ -713,9 +777,9 @@ object: "world" | WORLD
 }|]
 
 the elements @tt{sentence}, @tt{verb}, @tt{greeting}, and @tt{object} are rule
-identifiers. The first rule, @litchar{sentence: verb optional-adjective
+identifiers.  The first rule, @litchar{sentence: verb optional-adjective
 object}, is a rule whose right side is an implicit pattern sequence of three
-sub-patterns. The uppercased @tt{WORLD} is a token identifier. The fourth rule in the program associates @tt{greeting} with a @tech{choice pattern}.
+sub-patterns.  The uppercased @tt{WORLD} is a token identifier.  The fourth rule in the program associates @tt{greeting} with a @tech{choice pattern}.
 
 
 
@@ -723,20 +787,20 @@ More examples:
 @itemize[
 
 @item{A
-BNF for binary
+@link["http://hashcollision.org/ragg/examples/01-equal.rkt"]{BNF} for binary
 strings that contain an equal number of zeros and ones.
 @verbatim|{
-#lang brag
+#lang br/ragg
 equal: [zero one | one zero]   ;; equal number of "0"s and "1"s.
 zero: "0" equal | equal "0"    ;; has an extra "0" in it.
 one: "1" equal | equal "1"     ;; has an extra "1" in it.
 }|
 }
 
-@item{A BNF for
+@item{A @link["http://hashcollision.org/ragg/examples/baby-json.rkt"]{BNF} for
 @link["http://www.json.org/"]{JSON}-like structures.
 @verbatim|{
-#lang brag
+#lang br/ragg
 json: number | string
     | array  | object
 number: NUMBER
@@ -748,26 +812,30 @@ kvpair: ID ":" json
 }
 ]
 
+The @link["https://github.com/dyoo/ragg"]{ragg github source repository}
+includes
+@link["https://github.com/dyoo/ragg/tree/master/ragg/examples"]{several more
+examples}.
 
 
 
 @subsection{Syntax errors}
 
 Besides the basic syntax errors that can occur with a malformed grammar, there
-are a few other classes of situations that @litchar{#lang brag} will consider
+are a few other classes of situations that @litchar{#lang br/ragg} will consider
 as syntax errors.
 
-@tt{brag} will raise a syntax error if the grammar:
+@tt{ragg} will raise a syntax error if the grammar:
 @itemize[
 @item{doesn't have any rules.}
 
 @item{has a rule with the same left hand side as any other rule.}
 
-@item{refers to rules that have not been defined. e.g. the
+@item{refers to rules that have not been defined.  e.g. the
 following program:
 @nested[#:style 'code-inset
 @verbatim|{
-#lang brag
+#lang br/ragg
 foo: [bar]
 }|
 ]
@@ -776,14 +844,14 @@ should raise an error because @tt{bar} has not been defined, even though
 
 
 @item{uses the token name @racket[EOF]; the end-of-file token type is reserved
-for internal use by @tt{brag}.}
+for internal use by @tt{ragg}.}
 
 
-@item{contains a rule that has no finite derivation. e.g. the following
+@item{contains a rule that has no finite derivation.  e.g. the following
 program:
 @nested[#:style 'code-inset
 @verbatim|{
-#lang brag
+#lang br/ragg
 infinite-a: "a" infinite-a
 }|
 ]
@@ -792,14 +860,14 @@ should raise an error because no finite sequence of tokens will satisfy
 
 ]
 
-Otherwise, @tt{brag} should be fairly tolerant and permit even ambiguous
+Otherwise, @tt{ragg} should be fairly tolerant and permit even ambiguous
 grammars.
 
 @subsection{Semantics}
-@declare-exporting[brag/examples/nested-word-list]
+@declare-exporting[br/ragg/examples/nested-word-list]
 
-A program written in @litchar{#lang brag} produces a module that provides a few
+A program written in @litchar{#lang br/ragg} produces a module that provides a few
-bindings. The most important of these is @racket[parse]:
+bindings.  The most important of these is @racket[parse]:
 
 @defproc[(parse [source any/c #f] 
                 [token-source (or/c (sequenceof token)
@@ -807,13 +875,13 @@ bindings. The most important of these is @racket[parse]:
          syntax?]{
 
 Parses the sequence of @tech{tokens} according to the rules in the grammar, using the
-first rule as the start production. The parse must completely consume
+first rule as the start production.  The parse must completely consume
 @racket[token-source].
 
 The @deftech{token source} can either be a sequence, or a 0-arity function that
 produces @tech{tokens}.
 
-A @deftech{token} in @tt{brag} can be any of the following values:
+A @deftech{token} in @tt{ragg} can be any of the following values:
 @itemize[
 @item{a string}
 @item{a symbol}
@@ -827,9 +895,9 @@ A token whose type is either @racket[void] or @racket['EOF] terminates the
 source.
 
 
-If @racket[parse] succeeds, it will return a structured syntax object. The
+If @racket[parse] succeeds, it will return a structured syntax object.  The
 structure of the syntax object follows the overall structure of the rules in
-the BNF grammar. For each rule @racket[r] and its associated pattern @racket[p],
+the BNF.  For each rule @racket[r] and its associated pattern @racket[p],
 @racket[parse] generates a syntax object @racket[#'(r p-value)] where
 @racket[p-value]'s structure follows a case analysis on @racket[p]:
 
@@ -848,7 +916,7 @@ pattern that informs the parser to introduces nested structure into the syntax
 object.
 
 
-If the grammar has ambiguity, @tt{brag} will choose and return a parse, though
+If the grammar has ambiguity, @tt{ragg} will choose and return a parse, though
 it does not guarantee which one it chooses.
 
 
@@ -859,7 +927,7 @@ If the parse cannot be performed successfully, or if a token in the
 
 
 It's often convenient to extract a parser for other non-terminal rules in the
-grammar, and not just for the first rule. A @tt{brag}-generated module also
+grammar, and not just for the first rule.  A @tt{ragg}-generated module also
 provides a form called @racket[make-rule-parser] to extract a parser for the
 other non-terminals:
 
@@ -868,11 +936,11 @@ other non-terminals:
 Constructs a parser for the @racket[name] of one of the non-terminals
 in the grammar.
 
-For example, given the @tt{brag} program
+For example, given the @tt{ragg} program
 @filepath{simple-arithmetic-grammar.rkt}:
 @filebox["simple-arithmetic-grammar.rkt"]{
 @verbatim|{
-#lang brag
+#lang br/ragg
 expr : term ('+' term)*
 term : factor ('*' factor)*
 factor : INT
@@ -881,7 +949,7 @@ factor : INT
 the following interaction shows how to extract a parser for @racket[term]s.
 @interaction[#:eval my-eval
 @eval:alts[(require "simple-arithmetic-grammar.rkt") 
-                    (require brag/examples/simple-arithmetic-grammar)]
+                    (require br/ragg/examples/simple-arithmetic-grammar)]
 (define term-parse (make-rule-parser term))
 (define tokens (list (token 'INT 3) 
                      "*" 
@@ -909,7 +977,7 @@ A set of all the token types used in a grammar.
 For example:
 @interaction[#:eval my-eval
 @eval:alts[(require "simple-arithmetic-grammar.rkt") 
-                    (require brag/examples/simple-arithmetic-grammar)]
+                    (require br/ragg/examples/simple-arithmetic-grammar)]
 all-token-types
 ]
 
@@ -921,10 +989,10 @@ all-token-types
 
 @section{Support API}
 
-@defmodule[brag/support]
+@defmodule[br/ragg/support]
 
-The @racketmodname[brag/support] module provides functions to interact with
+The @racketmodname[br/ragg/support] module provides functions to interact with
-@tt{brag} programs. The most useful is the @racket[token] function, which
+@tt{ragg} programs.  The most useful is the @racket[token] function, which
 produces tokens to be parsed.
 
 @defproc[(token [type (or/c string? symbol?)]
@@ -975,4 +1043,65 @@ DrRacket should highlight the offending locations in the source.}
 
 
 
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+@section{Caveats and things to do}
+
+Here are a few caveats and future aims for @tt{ragg}.
+
+@itemize[
+
+@item{@tt{ragg} doesn't currently have a good story about operator precedence.
+Future versions of @tt{ragg} will support the specification of operator
+precedence to deal with grammar ambiguity, probably by extending the BNF
+grammar rules in @litchar{#lang br/ragg} with keyword arguments.}
+
+
+@item{I currently depend on the lexer framework provided by
+@racketmodname[parser-tools/lex], which has a steeper learning curve than I'd
+like.  A future version of @tt{ragg} will probably try to provide a nicer set
+of tools for defining lexers.}
+
+
+@item{The underlying parsing engine (an Earley-style parser) has not been fully
+optimized, so it may exhibit degenerate parse times.  A future version of
+@tt{ragg} will guarantee @math{O(n^3)} time bounds so that at the very least,
+parses will be polynomial-time.}
+
+
+@item{@tt{ragg} doesn't yet have a good story on dealing with parser error
+recovery.  If a parse fails, it tries to provide the source location, but does
+little else.}
+
+@item{@tt{ragg} is slightly misnamed: what it really builds is a concrete
+syntax tree rather than an abstract syntax tree.  A future version of @tt{ragg}
+will probably support annotations on patterns so that they can be omitted or
+transformed in the parser output.}
+
+]
+
+
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+@;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+@section{Miscellaneous and thanks}
+
+Thanks to Matthew Flatt for pointing me to @racket[cfg-parser] from the
+@racket[cfg-parser] library.  Joe Politz gave me good advice and
+feedback.  Also, he suggested the name ``ragg''.  Other alternatives I'd been
+considering were ``autogrammar'' or ``chompy''.  Thankfully, he is a better
+Namer than me.  Daniel Patterson provided feedback that led to
+@racket[make-rule-parser].  Robby Findler and Guillaume Marceau provided
+steadfast suggestions to look into other parsing frameworks like
+@link["http://en.wikipedia.org/wiki/Syntax_Definition_Formalism"]{SDF} and
+@link["http://sablecc.org/"]{SableCC}.  Special thanks to Shriram
+Krishnamurthi, who convinced me that other people might find this package
+useful.
+
+
 @close-eval[my-eval]

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

@@ -5,11 +5,11 @@
          racket/set
          racket/syntax
          syntax/srcloc
-         brag/rules/stx-types
+         br/ragg/rules/stx-types
          "flatten.rkt"
          syntax/id-table
          (prefix-in sat: "satisfaction.rkt")
-         (prefix-in support: brag/support)
+         (prefix-in support: br/ragg/support)
          (prefix-in stxparse: syntax/parse))
 
 (provide rules-codegen)
@@ -28,7 +28,7 @@
        (define rules (syntax->list #'(r ...)))
 
        (when (empty? rules)
-         (raise-syntax-error 'brag
+         (raise-syntax-error 'ragg
                              (format "The grammar does not appear to have any rules")
                              stx))
 
@@ -44,7 +44,7 @@
        
        ;; The first rule, by default, is the start rule.
        (define rule-ids (for/list ([a-rule (in-list rules)])
-                                  (rule-id a-rule)))
+                          (rule-id a-rule)))
        (define start-id (first rule-ids))
        
        
@@ -88,9 +88,9 @@
            (begin             
              (require parser-tools/lex
                       parser-module
-                      brag/codegen/runtime
+                      br/ragg/codegen/runtime
-                      brag/support
+                      br/ragg/support
-                      brag/private/internal-support
+                      br/ragg/private/internal-support
                       racket/set
                       (for-syntax syntax/parse racket/base))
              
@@ -112,9 +112,9 @@
              ;; For internal use by the permissive tokenizer only:
              (define all-tokens-hash/mutable
                (make-hash (list ;; Note: we also allow the eof object here, to make
-                           ;; the permissive tokenizer even nicer to work with.
+                                ;; the permissive tokenizer even nicer to work with.
-                           (cons eof token-EOF) 
+                                (cons eof token-EOF) 
-                           (cons 'token-type token-type-constructor) ...)))
+                                (cons 'token-type token-type-constructor) ...)))
 
              
              #;(define default-lex/1
@@ -152,14 +152,7 @@
                                       (parameterize ([current-source source])
                                         (parse tokenizer))])))]))
              
-             (define parse (make-rule-parser start-id))
+             (define parse (make-rule-parser start-id))))))]))
-             (provide parse-tree)
-             (define (parse-tree x)
-               (let loop ([x (syntax->datum (parse x))])
-                 (cond
-                   [(list? x) (map loop x)]
-                   [(char? x) (format "~a" x)]
-                   [else x])))))))]))
 
 
 ;; Given a flattened rule, returns a syntax for the code that
@@ -179,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.
@@ -188,51 +184,45 @@
   (define translated-patterns
     (let loop ([primitive-patterns (syntax->list a-clause)])
       (cond
-        [(empty? primitive-patterns)
+       [(empty? primitive-patterns)
-         '()]
+        '()]
-        [else
+       [else
-         (cons (syntax-case (first primitive-patterns) (id lit token inferred-id)
+        (cons (syntax-case (first primitive-patterns) (id lit token inferred-id)
-                 [(id val)
+                [(id val)
-                  #'val]
+                 #'val]
-                 [(lit val)
+                [(lit val)
-                  (datum->syntax #f (string->symbol (syntax-e #'val)) #'val)]
+                 (datum->syntax #f (string->symbol (syntax-e #'val)) #'val)]
-                 [(token val)
+                [(token val)
-                  #'val]
+                 #'val]
-                 [(inferred-id val reason)
+                [(inferred-id val reason)
-                  #'val])
+                 #'val])
-               (loop (rest primitive-patterns)))])))
+              (loop (rest primitive-patterns)))])))
   
   (define translated-actions
     (for/list ([translated-pattern (in-list translated-patterns)]
                [primitive-pattern (syntax->list a-clause)]
                [pos (in-naturals 1)])
-              (if (eq? (syntax-property primitive-pattern 'hide) 'hide)
+      (with-syntax ([$X 
-                  #'null
+                     (format-id translated-pattern "$~a" pos)]
-                  (with-syntax ([$X 
+                    [$X-start-pos 
-                                 (format-id translated-pattern "$~a" pos)]
+                     (format-id translated-pattern "$~a-start-pos" pos)]
-                                [$X-start-pos 
+                    [$X-end-pos
-                                 (format-id translated-pattern "$~a-start-pos" pos)]
+                     (format-id translated-pattern "$~a-end-pos" pos)])
-                                [$X-end-pos
+        (syntax-case primitive-pattern (id lit token inferred-id)
-                                 (format-id translated-pattern "$~a-end-pos" pos)])
+          ;; When a rule usage is inferred, the value of $X is a syntax object
-                    (syntax-case primitive-pattern (id lit token inferred-id)
+          ;; whose head is the name of the inferred rule . We strip that out,
-                      
+          ;; leaving the residue to be absorbed.
-                      ;; When a rule usage is inferred, the value of $X is a syntax object
+          [(inferred-id val reason)
-                      ;; whose head is the name of the inferred rule . We strip that out,
+           (report* #'val #'reason)
-                      ;; leaving the residue to be absorbed.
+           #'(syntax-case $X ()
-                      [(inferred-id val reason)
+               [(inferred-rule-name . rest)
-                       #'(syntax-case $X ()
+                (syntax->list #'rest)])]
-                           [(inferred-rule-name . rest)
+          [(id val)
-                            (syntax->list #'rest)])]
+           #`(list $X)]
-                      [(id val)
+          [(lit val)
-                       ;; at this point, the 'hide property is either #f or "splice"
+           #`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
-                       ;; ('hide value is handled at the top of this conditional
+          [(token val)
-                       ;; we need to use boolean because a symbol is treated as an identifier.
+           #`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]))))
-                       ;; 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)
-                       #'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))])))))
   
   (define whole-rule-loc
     (if (empty? translated-patterns)
@@ -241,13 +231,11 @@
                       [$n-end-pos (format-id (last translated-patterns) "$~a-end-pos" (length translated-patterns))])
           #`(positions->srcloc $1-start-pos $n-end-pos))))
   
-  ;; move 'hide-or-splice-lhs-id property into function because name is datum-ized
   (with-syntax ([(translated-pattern ...) translated-patterns]
                 [(translated-action ...) translated-actions])
     #`[(translated-pattern ...)
        (rule-components->syntax '#,rule-name/false translated-action ...
-                                #:srcloc #,whole-rule-loc
+                                #:srcloc #,whole-rule-loc)]))
-                                #:hide-or-splice? #,(syntax-property rule-name/false 'hide-or-splice-lhs-id))]))
 
 
 
@@ -263,7 +251,7 @@
   (define-values (implicit explicit)
     (for/fold ([implicit '()]
                [explicit (list (datum->syntax (first rules) 'EOF))])
-              ([r (in-list rules)])
+        ([r (in-list rules)])
       (rule-collect-token-types r implicit explicit)))
   (values (reverse implicit) (reverse explicit)))
   
@@ -306,12 +294,12 @@
 ;; rule-id: rule -> identifier-stx
 ;; Get the binding id of a rule.
 (define (rule-id a-rule)
-  (syntax-case a-rule (rule)
+ (syntax-case a-rule (rule)
     [(rule id a-pattern)
      #'id]))
 
 (define (rule-pattern a-rule)
-  (syntax-case a-rule (rule)
+ (syntax-case a-rule (rule)
     [(rule id a-pattern)
      #'a-pattern]))
 
@@ -323,26 +311,26 @@
   (define table (make-free-id-table))
   ;; Pass one: collect all the defined rule names.
   (for ([a-rule (in-list rules)])
-       (free-id-table-set! table (rule-id a-rule) #t))
+    (free-id-table-set! table (rule-id a-rule) #t))
   ;; Pass two: check each referenced id, and make sure it's been defined.
   (for ([a-rule (in-list rules)])
-       (for ([referenced-id (in-list (rule-collect-used-ids a-rule))])
+    (for ([referenced-id (in-list (rule-collect-used-ids a-rule))])
-            (unless (free-id-table-ref table referenced-id (lambda () #f))
+      (unless (free-id-table-ref table referenced-id (lambda () #f))
-              (raise-syntax-error #f (format "Rule ~a has no definition" (syntax-e referenced-id))
+        (raise-syntax-error #f (format "Rule ~a has no definition" (syntax-e referenced-id))
-                                  referenced-id)))))
+                            referenced-id)))))
 
 ;; check-all-rules-no-duplicates!: (listof rule-stx) -> void
 (define (check-all-rules-no-duplicates! rules)
   (define table (make-free-id-table))
   ;; Pass one: collect all the defined rule names.
   (for ([a-rule (in-list rules)])
-       (define maybe-other-rule-id (free-id-table-ref table (rule-id a-rule) (lambda () #f)))
+    (define maybe-other-rule-id (free-id-table-ref table (rule-id a-rule) (lambda () #f)))
-       (when maybe-other-rule-id
+    (when maybe-other-rule-id
-         (raise-syntax-error #f (format "Rule ~a has a duplicate definition" (syntax-e (rule-id a-rule)))
+      (raise-syntax-error #f (format "Rule ~a has a duplicate definition" (syntax-e (rule-id a-rule)))
-                             (rule-id a-rule)
+                          (rule-id a-rule)
-                             #f
+                          #f
-                             (list (rule-id a-rule) maybe-other-rule-id)))
+                          (list (rule-id a-rule) maybe-other-rule-id)))
-       (free-id-table-set! table (rule-id a-rule) (rule-id a-rule))))
+    (free-id-table-set! table (rule-id a-rule) (rule-id a-rule))))
 
 
 
@@ -390,9 +378,9 @@
 (define (check-all-rules-satisfiable! rules)
   (define toplevel-rule-table (make-free-id-table))
   (for ([a-rule (in-list rules)])
-       (free-id-table-set! toplevel-rule-table 
+    (free-id-table-set! toplevel-rule-table 
-                           (rule-id a-rule) 
+                        (rule-id a-rule) 
-                           (sat:make-and)))
+                        (sat:make-and)))
   (define leaves '())
   
   (define (make-leaf)
@@ -412,8 +400,8 @@
        (begin
          (define an-or-node (sat:make-or))
          (for ([v (in-list (syntax->list #'(vals ...)))])
-              (define a-child (process-pattern v))
+           (define a-child (process-pattern v))
-              (sat:add-child! an-or-node a-child))
+           (sat:add-child! an-or-node a-child))
          an-or-node)]
       [(repeat min val)
        (syntax-case #'min ()
@@ -427,19 +415,19 @@
        (begin
          (define an-and-node (sat:make-and))
          (for ([v (in-list (syntax->list #'(vals ...)))])
-              (define a-child (process-pattern v))
+           (define a-child (process-pattern v))
-              (sat:add-child! an-and-node a-child))
+           (sat:add-child! an-and-node a-child))
          an-and-node)]))
   
   (for ([a-rule (in-list rules)])
-       (define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
+    (define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
-       (sat:add-child! rule-node (process-pattern (rule-pattern a-rule))))
+    (sat:add-child! rule-node (process-pattern (rule-pattern a-rule))))
   
   (for ([a-leaf leaves])
-       (sat:visit! a-leaf))
+    (sat:visit! a-leaf))
   
   (for ([a-rule (in-list rules)])
-       (define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
+    (define rule-node (free-id-table-ref toplevel-rule-table (rule-id a-rule)))
-       (unless (sat:node-yes? rule-node)
+    (unless (sat:node-yes? rule-node)
-         (raise-syntax-error #f (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
+      (raise-syntax-error #f (format "Rule ~a has no finite derivation" (syntax-e (rule-id a-rule)))
-                             (rule-id a-rule)))))
+                          (rule-id a-rule)))))

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

@@ -1,5 +1,5 @@
 #lang racket/base
-(require brag/rules/stx-types
+(require br/ragg/rules/stx-types
          (for-syntax racket/base))
 
 (provide flatten-rule

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

@@ -1,14 +1,14 @@
 #lang s-exp syntax/module-reader
-brag/codegen/sexp-based-lang
+br/ragg/codegen/sexp-based-lang
 #:read my-read
 #:read-syntax my-read-syntax
 #:info my-get-info
 #:whole-body-readers? #t
 
-(require brag/rules/parser
+(require br/ragg/rules/parser
-         brag/rules/lexer
+         br/ragg/rules/lexer
-         brag/rules/stx
+         br/ragg/rules/stx
-         brag/rules/rule-structs)
+         br/ragg/rules/rule-structs)
 
 (define (my-read in)
   (syntax->datum (my-read-syntax #f in)))

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

@@ -0,0 +1,174 @@
+#lang racket/base
+
+(require racket/match 
+         racket/list
+         racket/generator
+         (prefix-in lex: parser-tools/lex) 
+         br/ragg/support
+         br/ragg/private/internal-support)
+
+
+(provide THE-ERROR-HANDLER 
+         make-permissive-tokenizer
+         atomic-datum->syntax
+         positions->srcloc
+         rule-components->syntax)
+
+
+
+;; The level of indirection here is necessary since the yacc grammar wants a
+;; function value for the error handler up front.  We want to delay that decision
+;; till parse time.
+(define (THE-ERROR-HANDLER tok-ok? tok-name tok-value start-pos end-pos)
+  (match (positions->srcloc start-pos end-pos)
+    [(list src line col offset span)
+     ((current-parser-error-handler) tok-name 
+                                     tok-value
+                                     offset
+                                     line
+                                     col 
+                                     span)]))
+
+
+
+
+(define no-position (lex:position #f #f #f))
+(define (no-position? p)
+  (not 
+   (or (lex:position-line p)
+       (lex:position-col p)
+       (lex:position-offset p))))
+
+
+;; make-permissive-tokenizer: (U (sequenceof (U token token-struct eof void)) (-> (U token token-struct eof void))) hash -> (-> position-token)
+;; Creates a tokenizer from the given value.
+;; FIXME: clean up code.
+(define (make-permissive-tokenizer tokenizer token-type-hash)
+  (define tokenizer-thunk (cond
+                           [(sequence? tokenizer)
+                            (sequence->generator tokenizer)]
+                           [(procedure? tokenizer)
+                            tokenizer]))
+
+  ;; lookup: symbol any pos pos -> position-token
+  (define (lookup type val start-pos end-pos)
+    (lex:position-token
+     ((hash-ref token-type-hash type
+               (lambda ()
+                 ((current-tokenizer-error-handler) (format "~a" type) val
+                  (lex:position-offset start-pos)
+                  (lex:position-line start-pos)
+                  (lex:position-col start-pos)
+                  (and (number? (lex:position-offset start-pos))
+                       (number? (lex:position-offset end-pos))
+                       (- (lex:position-offset end-pos) 
+                          (lex:position-offset start-pos))))))
+      val)
+     start-pos end-pos))
+
+  (define (permissive-tokenizer)
+    (define next-token (tokenizer-thunk))
+    (let loop ([next-token next-token])
+    (match next-token
+      [(or (? eof-object?) (? void?))
+       (lookup 'EOF eof no-position no-position)]
+
+      [(? symbol?)
+       (lookup next-token next-token no-position no-position)]
+
+      [(? string?)
+       (lookup (string->symbol next-token) next-token no-position no-position)]
+
+      [(? char?)
+       (lookup (string->symbol (string next-token)) next-token no-position no-position)]
+
+      ;; Compatibility 
+      [(? lex:token?)
+       (loop (token (lex:token-name next-token)
+                    (lex:token-value next-token)))]
+      
+      [(token-struct type val offset line column span skip?)
+       (cond [skip?
+              ;; skip whitespace, and just tokenize again.
+              (permissive-tokenizer)]
+             
+             [(hash-has-key? token-type-hash type)
+              (define start-pos (lex:position offset line column))
+              ;; try to synthesize a consistent end position.
+              (define end-pos (lex:position (if (and (number? offset) (number? span))
+                                                    (+ offset span)
+                                                    offset)
+                                                line
+                                                (if (and (number? column) (number? span))
+                                                    (+ column span)
+                                                    column)))
+              (lookup type val start-pos end-pos)]
+             [else
+              ;; We ran into a token of unrecognized type.  Let's raise an appropriate error.
+              ((current-tokenizer-error-handler) type val 
+               offset line column span)])]
+      
+      [(lex:position-token t s e)
+       (define a-position-token (loop t))
+       (lex:position-token (lex:position-token-token a-position-token)
+                           (if (no-position? (lex:position-token-start-pos a-position-token))
+                               s
+                               (lex:position-token-start-pos a-position-token))
+                           (if (no-position? (lex:position-token-end-pos a-position-token))
+                               e
+                               (lex:position-token-end-pos a-position-token)))]
+      
+      [else
+       ;; Otherwise, we have no idea how to treat this as a token.
+       ((current-tokenizer-error-handler) 'unknown-type (format "~a" next-token)
+        #f #f #f #f)])))
+  permissive-tokenizer)
+
+                      
+
+;; positions->srcloc: position position -> (list source line column offset span)
+;; Given two positions, returns a srcloc-like structure, where srcloc is the value
+;; consumed as the third argument to datum->syntax.
+(define (positions->srcloc start-pos end-pos)
+  (list (current-source)
+        (lex:position-line start-pos)
+        (lex:position-col start-pos)
+        (lex:position-offset start-pos)
+        (if (and (number? (lex:position-offset end-pos))
+                 (number? (lex:position-offset start-pos)))
+            (- (lex:position-offset end-pos)
+               (lex:position-offset start-pos))
+            #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.
+(define stx-with-original?-property
+  (read-syntax #f (open-input-string "original")))
+
+
+;; atomic-datum->syntax: datum position position
+;; 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)
+  (syntax-property (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property) 'foo 'atom))
+
+
+
+;; 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] . components)
+  (define flattened-components (apply append components))
+  (syntax-property (datum->syntax #f 
+                 (apply append
+                        (list 
+                         (syntax-property (datum->syntax #f rule-name/false srcloc stx-with-original?-property) 'foo 'rule-name))
+                        components)
+                 srcloc
+                 stx-with-original?-property) 'foo 'whole-rule))

beautiful-racket-ragg/br/ragg/codegen/sexp-based-lang.rkt

@@ -11,7 +11,7 @@
 ;; The intended use of this language is as follows:
 ;;
 ;;;;; s-exp-grammar.rkt ;;;;;;;;;
-;; #lang brag
+;; #lang br/ragg
 ;; s-exp : "(" s-exp* ")" | ATOM
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -27,7 +27,7 @@
 ;; defines what the uppercased tokens mean.  For example, you can
 ;; use the parser-tools/lex lexer tools:
 ;;
-;; (require brag/support
+;; (require ragg/support
 ;;          parser-tools/lex
 ;;          parser-tools/lex-sre)
 ;;
@@ -91,6 +91,6 @@
          #%top-interaction)
 
 (define-syntax (rules stx)
-  (rules-codegen #:parser-provider-module 'brag/cfg-parser/cfg-parser ;; 'parser-tools/yacc 
+  (rules-codegen #:parser-provider-module 'br/ragg/cfg-parser/cfg-parser ;; 'parser-tools/yacc 
                  #:parser-provider-form   'cfg-parser                 ;; 'parser
                  stx))

beautiful-racket-ragg/br/ragg/examples/01-equal.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ## Equal numbers of 0 and 1s in a string.
 ##

beautiful-racket-ragg/br/ragg/examples/0n1.rkt

@@ -1,3 +1,3 @@
-#lang brag
+#lang br/ragg
 
 rule: "0"* "1"

beautiful-racket-ragg/br/ragg/examples/0n1n.rkt

@@ -1,3 +1,3 @@
-#lang brag
+#lang br/ragg
 
 rule-0n1n: ["0" rule-0n1n "1"]

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

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ;; Simple baby example of JSON structure
 json: number | string

beautiful-racket-ragg/br/ragg/examples/bnf.rkt

@@ -1,11 +1,4 @@
-#lang racket/base
+#lang br/ragg
-
-#|
-This grammar is permanently broken with the <elider> operator active.
-|#
-
-
-#|
 
 
 ## The following comes from: http://en.wikipedia.org/wiki/Backus%E2%80%93Naur_Form
@@ -19,5 +12,3 @@ This grammar is permanently broken with the <elider> operator active.
 <list>    : <term> | <term> <opt-whitespace> <list>
 <term>    : <literal> | "<" <RULE-NAME> ">"
 <literal> : '"' <TEXT> '"' | "'" <TEXT> "'"   ## actually, the original BNF did not use quotes
-
-|#

beautiful-racket-ragg/br/ragg/examples/lua-parser.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ;; Lua parser, adapted from:
 ;; http://www.lua.org/manual/5.1/manual.html#8

beautiful-racket-ragg/br/ragg/examples/nested-word-list.rkt

@@ -1,3 +1,3 @@
-#lang brag
+#lang br/ragg
 nested-word-list: WORD
                 | LEFT-PAREN nested-word-list* RIGHT-PAREN

beautiful-racket-ragg/br/ragg/examples/python-grammar.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 # Grammar for Python
 

beautiful-racket-ragg/br/ragg/examples/simple-arithmetic-grammar.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 expr : term ('+' term)*
 term : factor ('*' factor)*

beautiful-racket-ragg/br/ragg/examples/simple-line-drawing.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ;;
 ;; See: http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket

beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/examples/letter-i.rkt

@@ -0,0 +1,4 @@
+#lang br/ragg/examples/simple-line-drawing
+3 9 X;
+6 3 b 3 X 3 b;
+3 9 X;

beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/grammar.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ;;
 ;; See: http://stackoverflow.com/questions/12345647/rewrite-this-script-by-designing-an-interpreter-in-racket

beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/lang/reader.rkt

@@ -1,12 +1,12 @@
 #lang s-exp syntax/module-reader
-brag/examples/simple-line-drawing/semantics
+br/ragg/examples/simple-line-drawing/semantics
 #:read my-read
 #:read-syntax my-read-syntax
 #:info my-get-info
 #:whole-body-readers? #t
 
-(require brag/examples/simple-line-drawing/lexer
+(require br/ragg/examples/simple-line-drawing/lexer
-         brag/examples/simple-line-drawing/grammar)
+         br/ragg/examples/simple-line-drawing/grammar)
 
 (define (my-read in)
   (syntax->datum (my-read-syntax #f in)))

beautiful-racket-ragg/br/ragg/examples/simple-line-drawing/lexer.rkt

@@ -3,7 +3,7 @@
 (provide tokenize)
 
 ;; A simple lexer for simple-line-drawing.
-(require brag/support
+(require br/ragg/support
          parser-tools/lex)
 
 (define (tokenize ip)

beautiful-racket-ragg/br/ragg/examples/statlist-grammar.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ## Statlist grammar
 

beautiful-racket-ragg/br/ragg/examples/wordy.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 ;; A parser for a silly language
 sentence: verb optional-adjective object
 verb: greeting

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

@@ -0,0 +1,11 @@
+#lang setup/infotab
+(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")))
+(define blurb '("ragg: a Racket AST Generator Generator.  A design goal is to be easy for beginners to use. Given a grammar in EBNF, ragg produces a parser that generates Racket's native syntax objects with full source location."))
+(define release-notes '((p "First release.")))
+(define deps (list))

beautiful-racket-ragg/br/ragg/private/internal-support.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require brag/support)
+(require br/ragg/support)
 
 (provide current-source
          current-parser-error-handler
@@ -15,8 +15,8 @@
   (make-parameter
    (lambda (tok-name tok-value offset line col span)
      (raise (exn:fail:parsing
-                (format "Encountered parsing error near ~e (token ~e) while parsing ~e [line=~a, column=~a, offset=~a]"
+                (format "Encountered parsing error near token ~e (~e) while parsing ~e [line=~a, column=~a, offset=~a]"
-                        tok-value tok-name
+                        tok-name tok-value
                         (current-source)
                         line col offset)
                 (current-continuation-marks)

beautiful-racket-ragg/br/ragg/rules/lexer.rkt

@@ -1,33 +1,29 @@
 #lang racket/base
-(require (for-syntax racket/base "parser.rkt"))
 (require parser-tools/lex
          (prefix-in : parser-tools/lex-sre)
          "parser.rkt"
-         "rule-structs.rkt"
+         "rule-structs.rkt")
-         racket/string)
 
 (provide lex/1 tokenize)
 
 ;; A newline can be any one of the following.
 (define-lex-abbrev NL (:or "\r\n" "\r" "\n"))
 
-;; chars used for quantifiers & parse-tree filtering
+;; Slightly modified from the read.rkt example in parser-tools, treating
-(define-for-syntax quantifiers "+:*") ; colon is reserved to separate rules and productions
+;; +, :, and * as reserved, non-identifier characters.
-(define-lex-trans reserved-chars
-  (λ(stx) #`(char-set #,(format "~a~a~a" quantifiers hide-char splice-char))))
-
-(define-lex-trans hide-char-trans (λ(stx) #`(char-set #,(format "~a" hide-char))))
-(define-lex-trans splice-char-trans (λ(stx) #`(char-set #,(format "~a" splice-char))))
-
 (define-lex-abbrevs
-  [letter (:or (:/ "a" "z") (:/ #\A #\Z))]
+   [letter (:or (:/ "a" "z") (:/ #\A #\Z))]
-  [digit (:/ #\0 #\9)]
+   [digit (:/ #\0 #\9)]
-  [id-char (:or letter digit (:& (char-set "+:*@!-.$%&/=?^_~<>") (char-complement (reserved-chars))))]
+   [id-char (:or letter digit (char-set "-.!$%&/<=>?^_~@"))]
-  [hide-char (hide-char-trans)]
+ )
-  [splice-char (splice-char-trans)]
+
-  )
+(define-lex-abbrev id
+  (:& (complement (:+ digit))
+      (:+ id-char)))
+
+
+
 
-(define-lex-abbrev id (:& (complement (:+ digit)) (:+ id-char)))
 
 (define lex/1
   (lexer-src-pos
@@ -47,10 +43,6 @@
     (token-RPAREN lexeme)]
    ["]"
     (token-RBRACKET lexeme)]
-   [hide-char
-    (token-HIDE lexeme)]
-   [splice-char
-    (token-SPLICE lexeme)]
    ["|"
     (token-PIPE lexeme)]
    [(:or "+" "*")
@@ -59,33 +51,22 @@
     ;; Skip whitespace
     (return-without-pos (lex/1 input-port))]
    ;; Skip comments up to end of line
-   ;; but detect possble kwargs.
+   [(:: (:or "#" ";")
-   [(:: (:or "#" ";") ; remove # as comment char
         (complement (:: (:* any-char) NL (:* any-char)))
         (:or NL ""))
-    (let ([maybe-kwarg-match (regexp-match #px"^#:(.*?)\\s*(.*?)$" lexeme)])
+    ;; Skip comments up to end of line.
-      (when maybe-kwarg-match
+    (return-without-pos (lex/1 input-port))]
-        (let* ([parts (map string->symbol (string-split (string-trim lexeme "#:" #:right? #f)))]
-               [kw (car parts)][val (cadr parts)])
-          (case kw
-            [(prefix-out) (current-prefix-out val)]
-            [else (error 'lexer (format "got unknown keyword ~a" kw))])))
-      (return-without-pos (lex/1 input-port)))]
    [(eof)
     (token-EOF lexeme)]
    [(:: id (:* whitespace) ":")
     (token-RULE_HEAD lexeme)]
-   [(:: hide-char id (:* whitespace) ":")
-    (token-RULE_HEAD_HIDDEN lexeme)]
-   [(:: splice-char id (:* whitespace) ":")
-    (token-RULE_HEAD_SPLICED lexeme)]
    [id
     (token-ID lexeme)]
    
    ;; We call the error handler for everything else:
    [(:: any-char)
     (let-values ([(rest-of-text end-pos-2)
-                  (lex-nonwhitespace input-port)])
+                 (lex-nonwhitespace input-port)])
       ((current-parser-error-handler)
        #f
        'error

beautiful-racket-ragg/br/ragg/rules/parser.rkt

@@ -7,20 +7,14 @@
 
 ;; A parser for grammars.
 
-(provide hide-char
+(provide tokens
-         splice-char
-         tokens
          token-LPAREN
          token-RPAREN
-         token-HIDE ; for hider
-         token-SPLICE ; for splicer
          token-LBRACKET
          token-RBRACKET
          token-PIPE
          token-REPEAT
          token-RULE_HEAD
-         token-RULE_HEAD_HIDDEN
-         token-RULE_HEAD_SPLICED
          token-ID
          token-LIT
          token-EOF
@@ -28,7 +22,6 @@
 
          current-source
          current-parser-error-handler
-         current-prefix-out
          
          [struct-out rule]
          [struct-out lhs-id]
@@ -45,20 +38,13 @@
                        RPAREN
                        LBRACKET
                        RBRACKET
-                       HIDE
-                       SPLICE
                        PIPE
                        REPEAT
                        RULE_HEAD
-                       RULE_HEAD_HIDDEN
-                       RULE_HEAD_SPLICED
                        ID
                        LIT
                        EOF))
 
-(define hide-char #\/)
-(define splice-char #\@)
-
 ;; grammar-parser: (-> token) -> (listof rule)
 (define grammar-parser
   (parser
@@ -92,38 +78,7 @@
                               (string-length trimmed))
                            (position-line $1-start-pos)
                            (position-col $1-start-pos))
-                      trimmed
+                      trimmed)
-                      #f)
-              $2))]
-     
-     [(RULE_HEAD_HIDDEN pattern) ; bang indicates hiding
-      (begin
-        (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)
-                      (pos (+ (position-offset $1-start-pos)
-                              (string-length trimmed)
-                              (string-length "!"))
-                           (position-line $1-start-pos)
-                           (position-col $1-start-pos))
-                      trimmed
-                      ''hide) ; symbol needs to be double quoted in this case
-              $2))]
-     
-     [(RULE_HEAD_SPLICED pattern) ;atsign indicates splicinh
-      (begin
-        (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)
-                      (pos (+ (position-offset $1-start-pos)
-                              (string-length trimmed)
-                              (string-length "@"))
-                           (position-line $1-start-pos)
-                           (position-col $1-start-pos))
-                      trimmed
-                      ''splice) ; symbol needs to be double quoted in this case 
               $2))]]
 
     [pattern
@@ -169,19 +124,16 @@
      [(LIT)
       (pattern-lit (position->pos $1-start-pos)
                    (position->pos $1-end-pos)
-                   (substring $1 1 (sub1 (string-length $1)))
+                   (substring $1 1 (sub1 (string-length $1))))]
-                   #f)]
      
      [(ID)
       (if (token-id? $1)
           (pattern-token (position->pos $1-start-pos)
                          (position->pos $1-end-pos)
-                         $1
+                         $1)
-                         #f)
           (pattern-id (position->pos $1-start-pos)
                       (position->pos $1-end-pos)
-                      $1
+                      $1))]
-                      #f))]
 
      [(LBRACKET pattern RBRACKET)
       (pattern-maybe (position->pos $1-start-pos)
@@ -189,45 +141,33 @@
                      $2)]
      
      [(LPAREN pattern RPAREN)
-      (relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]
+      (relocate-pattern $2 (position->pos $1-start-pos) (position->pos $3-end-pos))]])
-     
-     [(HIDE atomic-pattern)
-      (relocate-pattern $2 (position->pos $1-start-pos) (position->pos $2-end-pos) 'hide)]
-
-     [(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)
-                      (position->pos $2-end-pos)
-                      $2
-                      'splice))]])
 
    
    (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))))))
 
+
 ;; relocate-pattern: pattern -> pattern
 ;; Rewrites the pattern's start and end pos accordingly.
-(define (relocate-pattern a-pat start-pos end-pos [hide? #f])
+(define (relocate-pattern a-pat start-pos end-pos)
   (match a-pat
-    [(pattern-id _ _ v h)
+   [(pattern-id _ _ v)
-     (pattern-id start-pos end-pos v (or hide? h))]
+    (pattern-id start-pos end-pos v)]
-    [(pattern-token _ _ v h)
+   [(pattern-token _ _ v)
-     (pattern-token start-pos end-pos v (or hide? h))]
+    (pattern-token start-pos end-pos v)]
-    [(pattern-lit _ _ v h)
+   [(pattern-lit _ _ v)
-     (pattern-lit start-pos end-pos v (or hide? h))]
+    (pattern-lit start-pos end-pos v)]
-    [(pattern-choice _ _ vs)
+   [(pattern-choice _ _ vs)
-     (pattern-choice start-pos end-pos vs)]
+    (pattern-choice start-pos end-pos vs)]
-    [(pattern-repeat _ _ m v)
+   [(pattern-repeat _ _ m v)
-     (pattern-repeat start-pos end-pos m v)]
+    (pattern-repeat start-pos end-pos m v)]
-    [(pattern-maybe _ _ v)
+   [(pattern-maybe _ _ v)
-     (pattern-maybe start-pos end-pos v)]
+    (pattern-maybe start-pos end-pos v)]
-    [(pattern-seq _ _ vs)
+   [(pattern-seq _ _ vs)
-     (pattern-seq start-pos end-pos vs)]
+    (pattern-seq start-pos end-pos vs)]
-    [else
+   [else
-     (error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))
+    (error 'relocate-pattern "Internal error when relocating ~s\n" a-pat)]))
 
 
 ; token-id: string -> boolean
@@ -251,14 +191,12 @@
 ;; During parsing, we should define the source of the input.
 (define current-source (make-parameter #f))
 
-(define current-prefix-out (make-parameter #f))
-
 
 ;; When bad things happen, we need to emit errors with source location.
 (struct exn:fail:parse-grammar exn:fail (srclocs)
-  #:transparent
+        #:transparent
-  #:property prop:exn:srclocs (lambda (instance)
+        #:property prop:exn:srclocs (lambda (instance)
-                                (exn:fail:parse-grammar-srclocs instance)))
+                                      (exn:fail:parse-grammar-srclocs instance)))
 
 (define current-parser-error-handler
   (make-parameter

beautiful-racket-ragg/br/ragg/rules/rule-structs.rkt

@@ -7,25 +7,29 @@
 (struct pos (offset line col)
         #:transparent)
 
+
+
 (struct rule (start end lhs pattern)
         #:transparent)
 
-(struct lhs-id (start end val splice)
+(struct lhs-id (start end val)
         #:transparent)
 
+
 ;; A pattern can be one of the following:
 (struct pattern (start end)
         #:transparent)
 
-(struct pattern-id pattern (val hide)
+(struct pattern-id pattern (val)
         #:transparent)
 
+
 ;; Token structure to be defined by the user
-(struct pattern-token pattern (val hide)
+(struct pattern-token pattern (val)
         #:transparent)
 
 ;; Token structure defined as the literal string to be matched.
-(struct pattern-lit pattern (val hide)
+(struct pattern-lit pattern (val)
         #:transparent)
 
 (struct pattern-choice pattern (vals)

beautiful-racket-ragg/br/ragg/rules/stx.rkt

@@ -0,0 +1,76 @@
+#lang racket/base
+
+(require "rule-structs.rkt"
+         parser-tools/lex
+         racket/match
+         syntax/strip-context)
+
+(provide rules->stx)
+
+;; Given a sequence of rules, we translate these to syntax objects.
+
+;; rules->stx: (listof rule) -> syntax
+(define (rules->stx source rules #:original-stx [original-stx #f])
+  (define rule-stxs
+    (map (lambda (stx) (rule->stx source stx))
+         rules))
+  (datum->syntax #f
+                 `(rules ,@rule-stxs)
+                 original-stx))
+
+
+(define (rule->stx source a-rule)
+  (define id-stx
+    (datum->syntax #f
+                   (string->symbol (lhs-id-val (rule-lhs a-rule)))
+                   (list source
+                         (pos-line (lhs-id-start (rule-lhs a-rule)))
+                         (pos-col (lhs-id-start (rule-lhs a-rule)))
+                         (pos-offset (lhs-id-start (rule-lhs a-rule)))
+                         (if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
+                                  (number? (pos-offset (lhs-id-end (rule-lhs a-rule)))))
+                             (- (pos-offset (lhs-id-end (rule-lhs a-rule)))
+                                (pos-offset (lhs-id-start (rule-lhs a-rule))))
+                             #f))))
+  (define pattern-stx (pattern->stx source (rule-pattern a-rule)))
+  (define line (pos-line (rule-start a-rule)))
+  (define column (pos-col (rule-start a-rule)))
+  (define position (pos-offset (rule-start a-rule)))
+  (define span (if (and (number? (pos-offset (rule-start a-rule)))
+                        (number? (pos-offset (rule-end a-rule))))
+                   (- (pos-offset (rule-end a-rule))
+                      (pos-offset (rule-start a-rule)))
+                   #f))
+  (datum->syntax #f
+                 `(rule ,id-stx ,pattern-stx)
+                 (list source line column position span)))
+
+(define (pattern->stx source a-pattern)
+  (define recur (lambda (s) (pattern->stx source s)))
+  
+  (define line (pos-line (pattern-start a-pattern)))
+  (define column (pos-col (pattern-start a-pattern)))
+  (define position (pos-offset (pattern-start a-pattern)))
+  (define span (if (and (number? (pos-offset (pattern-start a-pattern)))
+                        (number? (pos-offset (pattern-end a-pattern))))
+                   (- (pos-offset (pattern-end a-pattern))
+                      (pos-offset (pattern-start a-pattern)))
+                   #f))
+  (define source-location (list source line column position span))
+  (datum->syntax #f
+                 (match a-pattern
+                   [(struct pattern-id (start end val))
+                    `(id ,(datum->syntax #f (string->symbol val) source-location))]
+                   [(struct pattern-lit (start end val))
+                    `(lit ,(datum->syntax #f val source-location))]
+                   [(struct pattern-token (start end val))
+                    `(token ,(datum->syntax #f (string->symbol val) source-location))]
+                   [(struct pattern-choice (start end vals))
+                    `(choice ,@(map recur vals))]
+                   [(struct pattern-repeat (start end min val))
+                    `(repeat ,min ,(recur val))]
+                   [(struct pattern-maybe (start end val))
+                    `(maybe ,(recur val))]
+                   [(struct pattern-seq (start end vals))
+                    `(seq ,@(map recur vals))])
+                 source-location))

beautiful-racket-ragg/br/ragg/test/exercise-python-grammar.rkt

@@ -1,6 +1,6 @@
 #lang racket
-(require brag/examples/python-grammar
+(require br/ragg/examples/python-grammar
-         brag/support
+         br/ragg/support
          python-tokenizer
          racket/generator
          parser-tools/lex

beautiful-racket-ragg/br/ragg/test/test-01-equal.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require brag/examples/01-equal
+(require br/ragg/examples/01-equal
          rackunit)
 
 (check-equal? (syntax->datum (parse ""))

beautiful-racket-ragg/br/ragg/test/test-0n1.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 
-(require brag/examples/0n1
+(require br/ragg/examples/0n1
-         brag/support
+         br/ragg/support
          rackunit)
 
 (define (lex ip)

beautiful-racket-ragg/br/ragg/test/test-0n1n.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
-(require brag/examples/0n1n
+(require br/ragg/examples/0n1n
-         brag/support
+         br/ragg/support
          rackunit)
 
 (define (lex ip)

beautiful-racket-ragg/br/ragg/test/test-all.rkt

@@ -6,7 +6,6 @@
          "test-01-equal.rkt"
          "test-simple-arithmetic-grammar.rkt"
          "test-baby-json.rkt"
-         "test-baby-json-hider.rkt"
          "test-wordy.rkt"
          "test-simple-line-drawing.rkt"
          "test-flatten.rkt"
@@ -16,4 +15,4 @@
          "test-errors.rkt"
          "test-old-token.rkt"
          "test-weird-grammar.rkt"
-         (submod brag/codegen/satisfaction test))
+         (submod br/ragg/codegen/satisfaction test))

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

@@ -1,6 +1,6 @@
 #lang racket/base
-(require brag/examples/baby-json
+(require br/ragg/examples/baby-json
-         brag/support
+         br/ragg/support
          rackunit)
 
 (check-equal?
@@ -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 #\{ #\})) #\])) #\])) #\])))

beautiful-racket-ragg/br/ragg/test/test-errors.rkt

@@ -36,50 +36,50 @@
 
 
 ;; errors with position are sensitive to length of lang line
-(define lang-line "#lang brag")
+(define lang-line "#lang br/ragg")
                      
 (check-compile-error (format "~a" lang-line)
                      "The grammar does not appear to have any rules")
 
 (check-compile-error (format "~a\nfoo" lang-line)
-                     "Error while parsing grammar near: foo [line=2, column=0, position=12]")
+                     "Error while parsing grammar near: foo [line=2, column=0, position=15]")
 
 (check-compile-error (format "~a\nnumber : 42" lang-line)
-                     "Error while parsing grammar near: 42 [line=2, column=9, position=21]")
+                     "Error while parsing grammar near: 42 [line=2, column=9, position=24]")
 
 (check-compile-error (format "~a\nnumber : 1" lang-line)
-                     "Error while parsing grammar near: 1 [line=2, column=9, position=21]")
+                     "Error while parsing grammar near: 1 [line=2, column=9, position=24]")
 
 
 
-(check-compile-error "#lang brag\n x: NUMBER\nx:STRING"
+(check-compile-error "#lang br/ragg\n x: NUMBER\nx:STRING"
                      "Rule x has a duplicate definition")
 
 ;; Check to see that missing definitions for rules also raise good syntax
 ;; errors:
 
-(check-compile-error "#lang brag\nx:y"
+(check-compile-error "#lang br/ragg\nx:y"
                      "Rule y has no definition")
 
-(check-compile-error "#lang brag\nnumber : 1flarbl"
+(check-compile-error "#lang br/ragg\nnumber : 1flarbl"
                      "Rule 1flarbl has no definition")
 
 
 
 
-(check-compile-error "#lang brag\nprogram: EOF"
+(check-compile-error "#lang br/ragg\nprogram: EOF"
                      "Token EOF is reserved and can not be used in a grammar")
 
 
 
 ;; Nontermination checks:
-(check-compile-error "#lang brag\nx : x"
+(check-compile-error "#lang br/ragg\nx : x"
                      "Rule x has no finite derivation")
 
 
 
 (check-compile-error #<<EOF
-#lang brag
+#lang br/ragg
 x : x y
 y : "y"
 EOF
@@ -90,7 +90,7 @@ EOF
 
 ; This should be illegal too:
 (check-compile-error #<<EOF
-#lang brag
+#lang br/ragg
 a : "a" b
 b : a | b 
 EOF
@@ -100,7 +100,7 @@ EOF
 
 
 (check-compile-error #<<EOF
-#lang brag
+#lang br/ragg
 a : [b]
 b : [c]
 c : c
@@ -109,7 +109,7 @@ EOF
 
 
 (check-compile-error #<<EOF
-#lang brag
+#lang br/ragg
 a : [b]
 b : c
 c : c
@@ -118,7 +118,7 @@ EOF
 
 
 (check-compile-error #<<EOF
-#lang brag
+#lang br/ragg
 a : [a]
 b : [b]
 c : c
@@ -130,7 +130,7 @@ EOF
 
 (check-compile-error #<<EOF
 #lang racket/base
-(require brag/examples/simple-line-drawing)
+(require br/ragg/examples/simple-line-drawing)
 (define bad-parser (make-rule-parser crunchy))
 EOF
                      "Rule crunchy is not defined in the grammar"

beautiful-racket-ragg/br/ragg/test/test-flatten.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
-(require brag/rules/stx-types
+(require br/ragg/rules/stx-types
-         brag/codegen/flatten
+         br/ragg/codegen/flatten
          rackunit)
 
 

beautiful-racket-ragg/br/ragg/test/test-lexer.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require brag/rules/lexer
+(require br/ragg/rules/lexer
          rackunit
          parser-tools/lex)
 
@@ -56,18 +56,3 @@
 
 (check-equal? (l "'he\\'llo'")
               '(LIT "'he\\'llo'" 1 10))
-
-(check-equal? (l "/")
-              '(HIDE "/" 1 2))
-
-(check-equal? (l " /")
-              '(HIDE "/" 2 3))
-
-(check-equal? (l "@")
-              '(SPLICE "@" 1 2))
-
-(check-equal? (l " @")
-              '(SPLICE "@" 2 3))
-
-(check-equal? (l "#:prefix-out val:")
-              (list 'EOF eof 18 18)) ; lexer skips kwarg

beautiful-racket-ragg/br/ragg/test/test-old-token.rkt

@@ -2,8 +2,8 @@
 
 ;; Make sure the old token type also works fine.
 
-(require brag/examples/simple-line-drawing
+(require br/ragg/examples/simple-line-drawing
-         brag/support
+         br/ragg/support
          racket/list
          parser-tools/lex
          (prefix-in : parser-tools/lex-sre)

beautiful-racket-ragg/br/ragg/test/test-parser.rkt

@@ -3,9 +3,9 @@
 
 (require rackunit
          parser-tools/lex
-         brag/rules/parser
+         br/ragg/rules/parser
-         brag/rules/lexer
+         br/ragg/rules/lexer
-         brag/rules/rule-structs)
+         br/ragg/rules/rule-structs)
 
 
 ;; quick-and-dirty helper for pos construction.
@@ -17,121 +17,97 @@
 ;; FIXME: fix the test cases so they work on locations rather than just offsets.
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'")))
               (list (rule (p 1) (p 15)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr" )
-                          (pattern-lit (p 8) (p 15) "hello" #f))))
+                          (pattern-lit (p 8) (p 15) "hello"))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON")))
               (list (rule (p 1) (p 13)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr")
-                          (pattern-token (p 8) (p 13) "COLON" #f))))
+                          (pattern-token (p 8) (p 13) "COLON"))))
 
-(check-equal? (grammar-parser (tokenize (open-input-string "/expr : COLON")))
+(check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON COLON")))
-              (list (rule (p 1) (p 14)
+              (list (rule (p 1) (p 19)
-                          (lhs-id (p 1) (p 6) "expr" ''hide)
+                          (lhs-id (p 1) (p 5) "expr")
-                          (pattern-token (p 9) (p 14) "COLON" #f))))
+                          (pattern-seq (p 8) (p 19)
-
-(check-equal? (grammar-parser (tokenize (open-input-string "@expr : COLON")))
-              (list (rule (p 1) (p 14)
-                          (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")))
-              (list (rule (p 1) (p 20)
-                          (lhs-id (p 1) (p 5) "expr" #f)
-                          (pattern-seq (p 8) (p 20)
                                    (list
-                                    (pattern-token (p 8) (p 14) "COLON" 'hide)
+                                    (pattern-token (p 8) (p 13) "COLON")
-                                    (pattern-token (p 15) (p 20) "COLON" #f))))))
+                                    (pattern-token (p 14) (p 19) "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)
-                                   (list
-                                    (pattern-id (p 8) (p 14) "thing" 'hide)
-                                    (pattern-token (p 15) (p 20) "COLON" #f))))))
-
-(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)
-                                   (list
-                                    (pattern-id (p 8) (p 14) "thing" 'splice)
-                                    (pattern-token (p 15) (p 20) "COLON" #f))))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'*")))
               (list (rule (p 1) (p 16)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr" )
                           (pattern-repeat (p 8) (p 16)
                                       0
-                                      (pattern-lit (p 8) (p 15) "hello" #f)))))
+                                      (pattern-lit (p 8) (p 15) "hello")))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : 'hello'+")))
               (list (rule (p 1) (p 16)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr" )
                           (pattern-repeat (p 8) (p 16)
                                       1
-                                      (pattern-lit (p 8) (p 15) "hello" #f)))))
+                                      (pattern-lit (p 8) (p 15) "hello")))))
 
-(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)
+              (list (rule (p 1) (p 17)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr" )
-                          (pattern-maybe (p 8) (p 18)
+                          (pattern-maybe (p 8) (p 17)
-                                     (pattern-lit (p 9) (p 17) "hello" 'hide)))))
+                                     (pattern-lit (p 9) (p 16) "hello")))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH")))
               (list (rule (p 1) (p 20)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr")
                           (pattern-choice (p 8) (p 20)
-                                      (list (pattern-token (p 8) (p 13) "COLON" #f)
+                                      (list (pattern-token (p 8) (p 13) "COLON")
-                                            (pattern-token (p 16) (p 20) "BLAH" #f))))))
+                                            (pattern-token (p 16) (p 20) "BLAH"))))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : COLON | BLAH | BAZ expr")))
               (list (rule (p 1) (p 31)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr")
                           (pattern-choice (p 8) (p 31)
-                                      (list (pattern-token (p 8) (p 13) "COLON" #f)
+                                      (list (pattern-token (p 8) (p 13) "COLON")
-                                            (pattern-token (p 16) (p 20) "BLAH" #f)
+                                            (pattern-token (p 16) (p 20) "BLAH")
                                             (pattern-seq (p 23) (p 31)
-                                                     (list (pattern-token (p 23) (p 26) "BAZ" #f)
+                                                     (list (pattern-token (p 23) (p 26) "BAZ")
-                                                           (pattern-id (p 27) (p 31) "expr" #f))))))))
+                                                           (pattern-id (p 27) (p 31) "expr"))))))))
+
+(check-equal? (grammar-parser (tokenize (open-input-string "expr : one two three")))
+              (list (rule (p 1) (p 21)
+                          (lhs-id (p 1) (p 5) "expr")
+                          (pattern-seq (p 8) (p 21) (list (pattern-id (p 8) (p 11) "one")
+                                              (pattern-id (p 12) (p 15) "two")
+                                              (pattern-id (p 16) (p 21) "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)
-                                              (pattern-id (p 12) (p 15) "two" #f)
-                                              (pattern-id (p 16) (p 22) "three" 'hide))))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two three)")))
               (list (rule (p 1) (p 23)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr")
-                          (pattern-seq (p 8) (p 23) (list (pattern-id (p 9) (p 12) "one" #f)
+                          (pattern-seq (p 8) (p 23) (list (pattern-id (p 9) (p 12) "one")
-                                                          (pattern-id (p 13) (p 16) "two" #f)
+                                                          (pattern-id (p 13) (p 16) "two")
-                                                          (pattern-id (p 17) (p 22) "three" #f))))))
+                                                          (pattern-id (p 17) (p 22) "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)
+                          (lhs-id (p 1) (p 5) "expr")
-                          (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
+                          (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one")
-                                              (pattern-repeat (p 12) (p 16) 0 (pattern-id (p 12) (p 15) "two" #f))
+                                              (pattern-repeat (p 12) (p 16) 0 (pattern-id (p 12) (p 15) "two"))
-                                              (pattern-id (p 17) (p 22) "three" #f))))))
+                                              (pattern-id (p 17) (p 22) "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)
+                          (lhs-id (p 1) (p 5) "expr")
-                          (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one" #f)
+                          (pattern-seq (p 8) (p 22) (list (pattern-id (p 8) (p 11) "one")
-                                              (pattern-repeat (p 12) (p 16) 1 (pattern-id (p 12) (p 15) "two" #f))
+                                              (pattern-repeat (p 12) (p 16) 1 (pattern-id (p 12) (p 15) "two"))
-                                              (pattern-id (p 17) (p 22) "three" #f))))))
+                                              (pattern-id (p 17) (p 22) "three"))))))
 
 (check-equal? (grammar-parser (tokenize (open-input-string "expr : (one two)+ three")))
               (list (rule (p 1) (p 24)
-                          (lhs-id (p 1) (p 5) "expr" #f)
+                          (lhs-id (p 1) (p 5) "expr")
                           (pattern-seq (p 8) (p 24) (list (pattern-repeat (p 8) (p 18) 1
                                                                           (pattern-seq (p 8) (p 17)
-                                                                                       (list (pattern-id (p 9) (p 12) "one" #f)
+                                                                                       (list (pattern-id (p 9) (p 12) "one")
-                                                                                             (pattern-id (p 13) (p 16) "two" #f))))
+                                                                                             (pattern-id (p 13) (p 16) "two"))))
-                                                          (pattern-id (p 19) (p 24) "three" #f))))))
+                                                          (pattern-id (p 19) (p 24) "three"))))))
 
 
 (check-equal? (grammar-parser (tokenize (open-input-string #<<EOF
@@ -141,13 +117,13 @@ stat: ID '=' expr
 EOF
 )))
               (list (rule (p 1) (p 17)
-                          (lhs-id (p 1) (p 9) "statlist" #f)
+                          (lhs-id (p 1) (p 9) "statlist")
-                          (pattern-repeat (p 12) (p 17) 1 (pattern-id (p 12) (p 16) "stat" #f)))
+                          (pattern-repeat (p 12) (p 17) 1 (pattern-id (p 12) (p 16) "stat")))
                     (rule (p 18) (p 54)
-                          (lhs-id (p 18) (p 22) "stat" #f)
+                          (lhs-id (p 18) (p 22) "stat")
-                          (pattern-choice (p 24) (p 54) (list (pattern-seq (p 24) (p 35) (list (pattern-token (p 24) (p 26) "ID" #f)
+                          (pattern-choice (p 24) (p 54) (list (pattern-seq (p 24) (p 35) (list (pattern-token (p 24) (p 26) "ID")
-                                                                       (pattern-lit (p 27) (p 30) "=" #f)
+                                                                       (pattern-lit (p 27) (p 30) "=")
-                                                                       (pattern-id (p 31) (p 35) "expr" #f)))
+                                                                       (pattern-id (p 31) (p 35) "expr")))
-                                                  (pattern-seq (p 42) (p 54) (list (pattern-lit (p 42) (p 49) "print" #f)
+                                                  (pattern-seq (p 42) (p 54) (list (pattern-lit (p 42) (p 49) "print")
-                                                                       (pattern-id (p 50) (p 54) "expr" #f))))))))
+                                                                       (pattern-id (p 50) (p 54) "expr"))))))))
 

beautiful-racket-ragg/br/ragg/test/test-simple-arithmetic-grammar.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
-(require brag/examples/simple-arithmetic-grammar
+(require br/ragg/examples/simple-arithmetic-grammar
-         brag/support
+         br/ragg/support
          racket/set
          parser-tools/lex
          racket/list

beautiful-racket-ragg/br/ragg/test/test-simple-line-drawing.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 
-(require brag/examples/simple-line-drawing
+(require br/ragg/examples/simple-line-drawing
-         brag/support
+         br/ragg/support
          racket/list
          parser-tools/lex
          (prefix-in : parser-tools/lex-sre)

beautiful-racket-ragg/br/ragg/test/test-wordy.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
-(require brag/examples/wordy
+(require br/ragg/examples/wordy
-         brag/support
+         br/ragg/support
          rackunit)
 
 (check-equal?

beautiful-racket-ragg/br/ragg/test/weird-grammar.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 
 ;; This used to fail when we had the yacc-based backend, but
 ;; cfg-parser seems to be ok with it.

beautiful-racket/br/demo/basic/3dplot.bas

@@ -1,19 +0,0 @@
-#lang br/demo/basic
-
-1 PRINT TAB(32);"3D PLOT"
-2 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
-3 PRINT:PRINT:PRINT
-5 DEF FNA(Z)=30*EXP(-Z*Z/100)
-100 PRINT
-110 FOR X=-30 TO 30 STEP 1.5
-120 L=0
-130 Y1=5*INT(SQR(900-X*X)/5)
-140 FOR Y=Y1 TO -Y1 STEP -5
-150 Z=INT(25+FNA(SQR(X*X+Y*Y))-.7*Y)
-160 IF Z<=L THEN 190
-170 L=Z
-180 PRINT TAB(Z);"*";
-190 NEXT Y
-200 PRINT
-210 NEXT X
-300 END

beautiful-racket/br/demo/basic/amazing.bas

@@ -1,140 +0,0 @@
-#lang br/demo/basic
-
-10 PRINT TAB(28);"AMAZING PROGRAM"
-20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
-30 PRINT:PRINT:PRINT:PRINT
-100 INPUT "WHAT ARE YOUR WIDTH AND LENGTH";HMAX,VMAX
-102 IF HMAX<>1 AND VMAX<>1 THEN 110
-104 PRINT "MEANINGLESS DIMENSIONS.  TRY AGAIN.":GOTO 100
-110 DIM W(HMAX,VMAX),V(HMAX,VMAX)
-120 PRINT
-130 PRINT
-140 PRINT
-150 PRINT
-160 Q=0:Z=0:X=INT(RND(1)*HMAX+1)
-165 FOR I=1 TO HMAX
-170 IF I=X THEN 173
-171 PRINT "+--";:GOTO 180
-173 PRINT "+  ";
-180 NEXT I
-190 PRINT "+"
-195 C=1:W(X,1)=C:C=C+1
-200 R=X:S=1:GOTO 260
-210 IF R<>HMAX THEN 240
-215 IF S<>VMAX THEN 230
-220 R=1:S=1:GOTO 250
-230 R=1:S=S+1:GOTO 250
-240 R=R+1
-250 IF W(R,S)=0 THEN 210
-260 IF R-1=0 THEN 530
-265 IF W(R-1,S)<>0 THEN 530
-270 IF S-1=0 THEN 390
-280 IF W(R,S-1)<>0 THEN 390
-290 IF R=HMAX THEN 330
-300 IF W(R+1,S)<>0 THEN 330
-310 X=INT(RND(1)*3+1)
-320 ON X GOTO 790,820,860
-330 IF S<>HMAX THEN 340
-334 IF Z=1 THEN 370
-338 Q=1:GOTO 350
-340 IF W(R,S+1)<>0 THEN 370
-350 X=INT(RND(1)*3+1)
-360 ON X GOTO 790,820,910
-370 X=INT(RND(1)*2+1)
-380 ON X GOTO 790,820
-390 IF R=HMAX THEN 470
-400 IF W(R+1,S)<>0 THEN 470
-405 IF S<>VMAX THEN 420
-410 IF Z=1 THEN 450
-415 Q=1:GOTO 430
-420 IF W(R,S+1)<>0 THEN 450
-430 X=INT(RND(1)*3+1)
-440 ON X GOTO 790,860,910
-450 X=INT(RND(1)*2+1)
-460 ON X GOTO 790,860
-470 IF S<>VMAX THEN 490
-480 IF Z=1 THEN 520
-485 Q=1:GOTO 500
-490 IF W(R,S+1)<>0 THEN 520
-500 X=INT(RND(1)*2+1)
-510 ON X GOTO 790,910
-520 GOTO 790
-530 IF S-1=0 THEN 670
-540 IF W(R,S-1)<>0 THEN 670
-545 IF R=HMAX THEN 610
-547 IF W(R+1,S)<>0 THEN 610
-550 IF S<>VMAX THEN 560
-552 IF Z=1 THEN 590
-554 Q=1:GOTO 570
-560 IF W(R,S+1)<>0 THEN 590
-570 X=INT(RND(1)*3+1)
-580 ON X GOTO 820,860,910
-590 X=INT(RND(1)*2+1)
-600 ON X GOTO 820,860
-610 IF S<>VMAX THEN 630
-620 IF Z=1 THEN 660
-625 Q=1:GOTO 640
-630 IF W(R,S+1)<>0 THEN 660
-640 X=INT(RND(1)*2+1)
-650 ON X GOTO 820,910
-660 GOTO 820
-670 IF R=HMAX THEN 740
-680 IF W(R+1,S)<>0 THEN 740
-685 IF S<>VMAX THEN 700
-690 IF Z=1 THEN 730
-695 Q=1:GOTO 830
-700 IF W(R,S+1)<>0 THEN 730
-710 X=INT(RND(1)*2+1)
-720 ON X GOTO 860,910
-730 GOTO 860
-740 IF S<>VMAX THEN 760
-750 IF Z=1 THEN 780
-755 Q=1:GOTO 770
-760 IF W(R,S+1)<>0 THEN 780
-770 GOTO 910
-780 GOTO 1000
-790 W(R-1,S)=C
-800 C=C+1:V(R-1,S)=2:R=R-1
-810 IF C=HMAX*VMAX+1 THEN 1010
-815 Q=0:GOTO 260
-820 W(R,S-1)=C
-830 C=C+1
-840 V(R,S-1)=1:S=S-1:IF C=HMAX*VMAX+1 THEN 1010
-850 Q=0:GOTO 260
-860 W(R+1,S)=C
-870 C=C+1:IF V(R,S)=0 THEN 880
-875 V(R,S)=3:GOTO 890
-880 V(R,S)=2
-890 R=R+1
-900 IF C=HMAX*VMAX+1 THEN 1010
-905 GOTO 530
-910 IF Q=1 THEN 960
-920 W(R,S+1)=C:C=C+1:IF V(R,S)=0 THEN 940
-930 V(R,S)=3:GOTO 950
-940 V(R,S)=1
-950 S=S+1:IF C=HMAX*VMAX+1 THEN 1010
-955 GOTO 260
-960 Z=1
-970 IF V(R,S)=0 THEN 980
-975 V(R,S)=3:Q=0:GOTO 1000
-980 V(R,S)=1:Q=0:R=1:S=1:GOTO 250
-1000 GOTO 210
-1010 FOR J=1 TO VMAX
-1011 PRINT "|";
-1012 FOR I=1 TO HMAX
-1013 IF V(I,J)<2 THEN 1030
-1020 PRINT "   ";
-1021 GOTO 1040
-1030 PRINT "  |";
-1040 NEXT I
-1041 PRINT
-1043 FOR I=1 TO HMAX
-1045 IF V(I,J)=0 THEN 1060
-1050 IF V(I,J)=2 THEN 1060
-1051 PRINT "+  ";
-1052 GOTO 1070
-1060 PRINT "+--";
-1070 NEXT I
-1071 PRINT "+"
-1072 NEXT J
-1073 END

beautiful-racket/br/demo/basic/bounce.bas

@@ -1,55 +0,0 @@
-#lang br/demo/basic
-
-10 PRINT TAB(33);"BOUNCE"
-20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
-30 PRINT:PRINT:PRINT
-90 DIM T(20)
-100 PRINT "THIS SIMULATION LETS YOU SPECIFY THE INITIAL VELOCITY"
-110 PRINT "OF A BALL THROWN STRAIGHT UP, AND THE COEFFICIENT OF"
-120 PRINT "ELASTICITY OF THE BALL.  PLEASE USE A DECIMAL FRACTION"
-130 PRINT "COEFFICIENCY (LESS THAN 1)."
-131 PRINT
-132 PRINT "YOU ALSO SPECIFY THE TIME INCREMENT TO BE USED IN"
-133 PRINT "'STROBING' THE BALL'S FLIGHT (TRY .1 INITIALLY)."
-134 PRINT
-135 INPUT "TIME INCREMENT (SEC)";S2
-140 PRINT
-150 INPUT "VELOCITY (FPS)";V
-160 PRINT
-170 INPUT "COEFFICIENT";C
-180 PRINT
-182 PRINT "FEET"
-184 PRINT
-186 S1=INT(70/(V/(16*S2)))
-190 FOR I=1 TO S1
-200 T(I)=V*C^(I-1)/16
-210 NEXT I
-220 FOR H=INT(-16*(V/32)^2+V^2/32+.5) TO 0 STEP -.5
-221 IF INT(H)<>H THEN 225
-222 PRINT H;
-225 L=0
-230 FOR I=1 TO S1
-240 FOR TI=0 TO T(I) STEP S2
-245 L=L+S2
-250 IF ABS(H-(.5*(-32)*TI^2+V*C^(I-1)*TI))>.25 THEN 270
-260 PRINT TAB(L/S2);"0";
-270 NEXT TI
-275 TI=T(I+1)/2
-276 IF -16*TI^2+V*C^(I-1)*TI<H THEN 290
-280 NEXT I
-290 PRINT
-300 NEXT H
-310 PRINT TAB(1);
-320 FOR I=1 TO INT(L+1)/S2+1
-330 PRINT ".";
-340 NEXT I
-350 PRINT
-355 PRINT " 0";
-360 FOR I=1 TO INT(L+.9995)
-380 PRINT TAB(INT(I/S2));I;
-390 NEXT I
-400 PRINT
-410 PRINT TAB(INT(L+1)/(2*S2)-2);"SECONDS"
-420 PRINT
-430 GOTO 135
-440 END

beautiful-racket/br/demo/basic/chemist.bas

@@ -1,30 +1,29 @@
 #lang br/demo/basic
 
-3 print TAB(33);"Chemist"
+3 PRINT TAB(33);"CHEMIST"
-6 print TAB(15);"Creative Computing | Morristown, New Jersey"
+6 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
-8 print:print:print
+8 PRINT:PRINT:PRINT
-10 print "The fictitious chemical kryptocyanic acid can only be"
+10 PRINT "THE FICTITIOUS CHECMICAL KRYPTOCYANIC ACID CAN ONLY BE"
-20 print "diluted by the ratio of 7 parts water to 3 parts acid."
+20 PRINT "DILUTED BY THE RATIO OF 7 PARTS WATER TO 3 PARTS ACID."
-30 print "if any other ratio is attempted, the acid becomes unstable"
+30 PRINT "IF ANY OTHER RATIO IS ATTEMPTED, THE ACID BECOMES UNSTABLE"
-40 print "and soon explodes. Given the amount of acid, you must"
+40 PRINT "AND SOON EXPLODES.  GIVEN THE AMOUNT OF ACID, YOU MUST"
-50 print "decide who much water to add for dilution. If you miss,"
+50 PRINT "DECIDE WHO MUCH WATER TO ADD FOR DILUTION.  IF YOU MISS"
-60 print "you face the consequences."
+60 PRINT "YOU FACE THE CONSEQUENCES."
-100 A=INT(RND(50))
+100 A=INT(RND(1)*50)
 110 W=7*A/3
-115 if A=1 then P="liter" else P="liters"
+120 PRINT A;"LITERS OF KRYPTOCYANIC ACID.  HOW MUCH WATER";
-120 print A; " "; P ; " of kryptocyanic acid. How much water?";
+130 INPUT R
-130 input R
 140 D=ABS(W-R)
-150 if D>W/20 then 200
+150 IF D>W/20 THEN 200
-160 print "Good job! You may breathe now, but don't inhale the fumes!"
+160 PRINT " GOOD JOB! YOU MAY BREATHE NOW, BUT DON'T INHALE THE FUMES!"
-170 print
+170 PRINT
-180 goto 100
+180 GOTO 100
-200 print "Sizzle! You have just been desalinated into a blob"
+200 PRINT " SIZZLE!  YOU HAVE JUST BEEN DESALINATED INTO A BLOB"
-210 print "of quivering protoplasm!"
+210 PRINT " OF QUIVERING PROTOPLASM!"
 220 T=T+1
-230 if T=3 then 260
+230 IF T=9 THEN 260
-240 print "However, you may try again with another life."
+240 PRINT " HOWEVER, YOU MAY TRY AGAIN WITH ANOTHER LIFE."
-250 goto 100
+250 GOTO 100
-260 print "Your 3 lives are used, but you will be long remembered for"
+260 PRINT " YOUR 9 LIVES ARE USED, BUT YOU WILL BE LONG REMEMBERED FOR"
-270 print "your contributions to the field of comic-book chemistry."
+270 PRINT " YOUR CONTRIBUTIONS TO THE FIELD OF COMIC BOOK CHEMISTRY."
-280 end
+280 END

beautiful-racket/br/demo/basic/dim.bas

@@ -1,7 +0,0 @@
-#lang br/demo/basic
-
-5 A=5
-10 DIM A(A)
-20 PRINT A /* this should print 5 */
-30 PRINT A(0)
-40 PRINT A(5)

beautiful-racket/br/demo/basic/expander.rkt

@@ -1,271 +1,162 @@
 #lang br
-(require (for-syntax syntax/strip-context))
 (provide #%top-interaction #%app #%datum
          (rename-out [basic-module-begin #%module-begin])
          (rename-out [basic-top #%top])
          (all-defined-out))
+(require br/stxparam (for-syntax br/datum))
 
 ; BASIC implementation details
 ; http://www.atariarchives.org/basicgames/showpage.php?page=i12
 
-(begin-for-syntax
+(define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""])
-  (require racket/list)
-  (define (gather-unique-ids stx)
-    (remove-duplicates (map syntax->datum (filter (λ(s) (syntax-property s 'id)) (syntax-flatten stx))) eq?)))
 
-(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
+(define #'(basic-module-begin _parse-tree ...)
-  (with-pattern ([(UNIQUE-ID ...)
+  #'(#%module-begin
-                  (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
+     (inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
-                       (gather-unique-ids #'(PROGRAM-LINE ...)))])
+                                (println (quote _parse-tree ...))
-    #'(#%module-begin
+                                _parse-tree ...)))
-       (define UNIQUE-ID 0) ...
-       (provide UNIQUE-ID ...)
-       (run PROGRAM-LINE ... (line #f (statement "end"))))))
 
 ; #%app and #%datum have to be present to make #%top work
-(define-macro (basic-top . ID)
+(define #'(basic-top . id)
   #'(begin
-      (displayln (format "got unbound identifier: ~a" 'ID))
+      (displayln (format "got unbound identifier: ~a" 'id))
-      (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
+      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
+
+(define #'(program _line ...) #'(run (list _line ...)))
+
 
 (struct exn:line-not-found exn:fail ())
-(define (raise-line-not-found-error ln)
-  (raise
-   (exn:line-not-found
-    (format "line number ~a not found in program" ln)
-    (current-continuation-marks))))
 
-(struct end-program-signal exn:fail ())
-(define (raise-end-program-signal)
-  (raise (end-program-signal "" (current-continuation-marks))))
 
-(struct end-line-signal exn:fail ())
+(define (run lines)
-(define (raise-end-line-signal)
+  (define program-lines (list->vector (filter (λ(ln) (not (equal? ln "cr"))) lines)))
-  (raise (end-line-signal "" (current-continuation-marks))))
+  (define (line-number->index ln)
-
-(define (run . line-list)
-  (define lines (list->vector line-list))
-  (define (find-index ln)
     (or
-     (for/or ([idx (in-range (vector-length lines))])
+     (for/or ([idx (in-range (vector-length program-lines))])
-             (and (= ($line-number (vector-ref lines idx)) ln)
+             (and (= (car (vector-ref program-lines idx)) ln)
                   idx))
-     (raise-line-not-found-error ln)))
+     (raise
-  (void
+      (exn:line-not-found
-   (with-handlers ([end-program-signal? void])
+       (format "line number ~a not found in program" ln)
-     (for/fold ([program-counter 0])
+       (current-continuation-marks)))))
-               ([i (in-naturals)])
+  (for/fold ([program-counter 0])
-       (let* ([line-thunk ($line-thunk (vector-ref lines program-counter))]
+            ([i (in-naturals)]
-              [maybe-line-number (line-thunk)])
+             #:break (eq? program-counter 'end))
-         (if (number? maybe-line-number)
+    (cond
-             (find-index maybe-line-number)
+      [(= program-counter (vector-length program-lines)) (basic:END)]
-             (add1 program-counter)))))))
+      [else
+       (define line-function (cdr (vector-ref program-lines program-counter)))
+       (define maybe-next-line (and line-function (line-function)))
+       (cond
+         [(number? maybe-next-line) (line-number->index maybe-next-line)]
+         [(eq? 'end maybe-next-line) 'end]
+         [else (add1 program-counter)])]))
+  (void))
 
-(define return-stack empty)
+(define #'(cr-line _arg ...) #'(begin _arg ...))
 
-(define (basic:gosub where)
-  (let/cc return-k
-    (set! return-stack (cons return-k return-stack))
-    (basic:goto where)))
 
-(define current-line (make-parameter #f))
+(define current-return-stack (make-parameter empty))
-(struct $line (number thunk))
-(define-macro (line NUMBER . STATEMENTS)
-  #'($line NUMBER (λ ()
-                    (current-line NUMBER)
-                    (with-handlers ([end-line-signal? (λ _ #f)]
-                                    [end-program-signal? raise]
-                                    [exn:fail? (λ(exn)
-                                                 (displayln (format "in line ~a" NUMBER))
-                                                 (raise exn))])
-                      . STATEMENTS))))
 
-(define-macro-cases statement
+(define-cases #'line
-  [(statement ID "=" EXPR) #'(basic:let ID EXPR)]
+  [#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE)))
-  [(statement PROC-NAME . ARGS)
+   #'(cons _NUMBER
-   (with-pattern
+           (λ _
-       ([PROC-ID (prefix-id "basic:" #'PROC-NAME)])
+             (let ([return-stack (current-return-stack)])
-     #'(PROC-ID . ARGS))])
+               (cond
+                 [(or (empty? return-stack)
+                      (not (= _NUMBER (car return-stack))))
+                  (current-return-stack (cons _NUMBER (current-return-stack)))
+                  (basic:GOTO _WHERE)]
+                 [else (current-return-stack (cdr (current-return-stack)))]))))]
+  [#'(_ _NUMBER _STATEMENT-LIST) #'(cons _NUMBER (λ _ _STATEMENT-LIST))])
 
-(define-macro-cases basic:let
+(define-cases #'statement-list
-  [(_ (id-expr ID) EXPR)
+  [#'(_ _STATEMENT) #'(begin _STATEMENT)]
-   #'(begin
+  [#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)])
-       #;(displayln (format "setting ~a = ~a in ~a" 'ID EXPR (current-line)))
-       (set! ID EXPR))]
-  [(_ (id-expr ID DIM-IDX ...) EXPR)
-   #'(array-set! ID DIM-IDX ... EXPR)])
 
-(define-macro-cases basic:if
+(define-cases #'statement
-  [(_ COND-EXPR TRUE-EXPR FALSE-EXPR)
+  [#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)]
-   #'(if (true? COND-EXPR)
+  ;[#'(statement "PRINT" ARG ...) #'(print ARG ...)]
-         TRUE-EXPR
+  ;[#'(statement "RETURN" ARG ...) #'(return ARG ...)]
-         FALSE-EXPR)]
+  ;[#'(statement "END" ARG ...) #'(end ARG ...)]
-  [(_ COND-EXPR TRUE-EXPR)
+  [#'(statement _proc-string _arg ...)
-   #'(if (true? COND-EXPR)
+   (inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)])
-         TRUE-EXPR
+                  #'(PROC-ID _arg ...))])
-         (raise-end-line-signal))]) ; special short-circuit rule for one-armed conditional
+
+(define-cases #'basic:IF
+  [#'(_ _COND "THEN" _TRUE-RESULT "ELSE" _FALSE-RESULT)
+   #'(if (true? _COND)
+         _TRUE-RESULT
+         _FALSE-RESULT)]
+  [#'(_ _COND "THEN" _TRUE-RESULT)
+   #'(when (true? _COND)
+       _TRUE-RESULT)])
+
+(define-cases #'value
+  [#'(value "(" _EXPR ")") #'_EXPR]
+  [#'(value _ID "(" _ARG ... ")") #'(_ID _ARG ...)]
+  [#'(value _ID-OR-DATUM) #'_ID-OR-DATUM])
 
 (define true? (compose1 not zero?))
 (define (cond->int cond) (if cond 1 0))
 (define (basic:and . args) (cond->int (andmap true? args)))
 (define (basic:or . args) (cond->int (ormap true? args)))
 
-(define-macro-cases id-expr
+(define-cases #'expr-list
-  [(_ ID) #'(cond
+  [#'(_ _EXPR) #'_EXPR]
-              [(procedure? ID) (ID)]
+  [#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)])
-              [(array? ID) (array-ref ID (make-vector (array-rank ID) 0))] ; no subscript => zeroth element
-              [else ID])]
-  [(_ ID EXPR0 EXPR ...) #'(cond
-                             [(procedure? ID) (ID EXPR0 EXPR ...)]
-                             [(array? ID) (array-ref ID EXPR0 EXPR ...)]
-                             [else (error 'id-expr-confused)])])
 
-(define-macro-cases expr
+(define-cases #'expr
-  [(_ COMP-EXPR) #'COMP-EXPR]
+  [#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)]
-  [(_ COMP-EXPR "and" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
+  [#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)]
-  [(_ COMP-EXPR "or" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)])
+  [#'(_ _COMP-EXPR) #'_COMP-EXPR])
-
-(define-macro-cases comp-expr
-  [(_ SUM) #'SUM]
-  [(_ SUM "=" COMP-EXPR)
-   #'(cond->int (equal? SUM COMP-EXPR))] ; special case because `=` is overloaded in basic
-  [(_ SUM OP-STR COMP-EXPR)
-   (with-pattern
-       ([OP (replace-context #'here (prefix-id #'OP-STR))])
-     #'(cond->int (OP SUM COMP-EXPR)))])
 
+(define-cases #'comp-expr
+  [#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
+  [#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
+                                          #'(cond->int (OP _LEXPR _REXPR)))]
+  [#'(_ _ARG) #'_ARG])
 (define <> (compose1 not equal?))
 
-(define-macro-cases sum
+(define-cases #'sum
-  [(_ SUM) #'SUM]
+  [#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)]
-  [(_ SUM "+" PRODUCT) #'(+ SUM PRODUCT)]
+  [#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)]
-  [(_ SUM "-" PRODUCT) #'(- SUM PRODUCT)])
+  [#'(_ _TERM) #'_TERM])
 
-(define-macro-cases product
+(define-cases #'product
-  [(_ "-" VALUE) #'(- VALUE)]
+  [#'(_ _value "*" _product) #'(* _value _product)]
-  [(_ VALUE) #'VALUE]
+  [#'(_ _value "/" _product) #'(/ _value _product)]
-  [(_ PRODUCT "*" VALUE) #'(* PRODUCT VALUE)]
+  [#'(_ _value) #'_value])
-  [(_ PRODUCT "/" VALUE) #'(/ PRODUCT VALUE)])
-
-(define-macro-cases power
-  [(_ BASE) #'BASE]
-  [(_ BASE POWER) #'(expt BASE POWER)])
-
-(define-macro-cases number
-  [(_ "-" NUM) #'(- NUM)]
-  [(_ NUM) #'NUM])
-
-(define-macro-cases id-val
-  [(_ "-" ID) #'(- ID)]
-  [(_ ID) #'ID])
 
 (define print-list list)
 
-(define (basic:print [args #f])
+(define (basic:PRINT args)
-  (define (println [x ""])
-    (define xstr (format "~a" x))
-    (displayln xstr)
-    (set! current-print-position 0))
-  (define (print x)
-    (define xstr (format "~a" x))
-    (display xstr)
-    (set! current-print-position (+ current-print-position (string-length xstr))))
-  
   (match args
-    [#f (println)]
+    [(list) (displayln "")]
-    [(list print-list-items ... ";" pl)
+    [(list print-list-item ... ";" pl) (begin (for-each display print-list-item)
-     (begin
+                                              (basic:PRINT pl))]
-       (for-each
+    [(list print-list-item ... ";") (for-each display print-list-item)]
-        (λ(pli)
+    [(list print-list-item ...) (for-each displayln print-list-item)]))
-          (print (if (number? pli)
-                     (format "~a " pli)
-                     pli)))
-        print-list-items)
-       (basic:print pl))]
-    [(list print-list-items ... ";") (for-each print print-list-items)]
-    [(list print-list-items ...)
-     (for-each println print-list-items)]))
 
-(define current-print-position 0)
+(define (TAB num) (make-string num #\space))
-(define (TAB num) (make-string (max 0 (INT (- num current-print-position))) #\space))
+(define #'(INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
-(define (INT num) (inexact->exact (truncate num)))
 (define (SIN num) (sin num))
 (define (ABS num) (inexact->exact (abs num)))
 (define (RND num) (* (random) num))
-(define (EXP num) (exp num))
-(define (SQR num) (sqrt num))
 
-(define-macro-cases basic:input
+(define-cases #'basic:INPUT
-  [(_ (print-list . PL-ITEMS) ID ...)
+  [#'(_ _PRINT-LIST ";" _ID)
    #'(begin
-       (basic:print (append (print-list . PL-ITEMS) (list ";")))
+       (basic:PRINT (append _PRINT-LIST (list ";")))
-       (basic:input ID) ...)]
+       (basic:INPUT _ID))]
-  [(_ ID ...) #'(begin
+  [#'(_ _ID) #'(set! _ID (let* ([str (read-line)]
-                  (set! ID (let* ([str (read-line)]
+                                [num (string->number str)])
-                                  [num (string->number (string-trim str))])
+                           (if num num str)))])
-                             (or num str))) ...)])
 
-(define (basic:goto where) where)
+(define (basic:GOTO where) where)
 
-(define-macro-cases basic:on
+(define (basic:RETURN) (car (current-return-stack)))
-  [(_ TEST-EXPR "goto" OPTION ...)
-   #'(basic:goto (list-ref (list OPTION ...) (sub1 TEST-EXPR)))]
-  [(_ TEST-EXPR "gosub" OPTION ...)
-   #'(basic:gosub (list-ref (list OPTION ...) (sub1 TEST-EXPR)))])
 
-
+(define (basic:END)
-(define (basic:return)
+  'end)
-  (define return-k (car return-stack))
-  (set! return-stack (cdr return-stack))
-  (return-k #f))
-
-(define (basic:stop) (basic:end))
-(define (basic:end) (raise-end-program-signal))
-
-(require srfi/25)
-
-(define-macro (basic:dim (id-expr ID EXPR ...) ...)
-  #'(begin
-      (set! ID (make-array (apply shape (append (list 0 (add1 EXPR)) ...)))) ...))
-
-(define for-stack empty)
-
-(define (push-for-stack thunk)
-  (set! for-stack (cons thunk for-stack)))
-
-(define (pop-for-stack)
-  (set! for-stack (cdr for-stack)))
-
-(define (in-closed-interval? x left right)
-  (define cmp (if (< left right) <= >=))
-  (cmp left x right))
-
-(define-macro-cases basic:for
-  [(_ VAR START-VALUE END-VALUE)
-   #'(basic:for VAR START-VALUE END-VALUE 1)]
-  [(_ VAR START-VALUE END-VALUE STEP-VALUE)
-   #'(begin
-       (statement (id-expr VAR) "=" START-VALUE) ; initialize the loop counter
-       (let/cc return-k ; create a return point
-         (push-for-stack (cons 'VAR
-                               (λ () ; thunk that increments counter & teleports back to beginning of loop
-                                 (define next-val (+ VAR STEP-VALUE))
-                                 (if (next-val . in-closed-interval? . START-VALUE END-VALUE)
-                                     (begin
-                                       (set! VAR next-val)
-                                       (return-k #f)) ; return value for subsequent visits to line
-                                     (pop-for-stack)))))
-         #f))]) ; return value for first visit to line
-
-(define (handle-next [which #f])
-  (unless (pair? for-stack) (error 'next "for-stack is empty"))
-  (define for-thunk (cdr (if which
-                             (assq which for-stack)
-                             (car for-stack))))
-  (for-thunk))
-
-(define-macro (basic:next VAR ...)
-  #'(handle-next 'VAR ...))
-
-(define-macro (basic:def DEF-ID LAMBDA-ID EXPR)
-  #'(set! DEF-ID (λ (LAMBDA-ID) EXPR)))

beautiful-racket/br/demo/basic/for.bas

@@ -1,8 +0,0 @@
-#lang br/demo/basic
-10 for A=1 to 3 
-20 print A
-21 for B=5 to 8
-22 print B
-23 next B
-30 next A
-40 print "yay"

beautiful-racket/br/demo/basic/gosub.bas

@@ -1,9 +1,9 @@
 #lang br/demo/basic
 10 GOSUB 50
-15 PRINT "2 of 3"
+15 PRINT "BOOM"
 17 GOSUB 30
 20 END
-30 PRINT "3 of 3"
+30 PRINT "YAY"
 40 RETURN
-50 PRINT "1 of 3"
+50 PRINT "50"
 55 RETURN

beautiful-racket/br/demo/basic/importest.rkt

@@ -1,2 +0,0 @@
-#lang racket
-(require "for.bas")

beautiful-racket/br/demo/basic/on.bas

@@ -1,11 +0,0 @@
-#lang br/demo/basic
-10 X = 3
-20 on X gosub 210, 220, 230
-21 print "yay"
-22 end
-210 print "one"
-211 return
-220 print "two"
-221 return
-230 print "three"
-231 return

beautiful-racket/br/demo/basic/parser.rkt

@@ -1,45 +1,35 @@
-#lang brag
+#lang br/ragg
 
-basic-program : line*
+;; recursive rules destucture easily in the expander
+program : [CR]* [line [CR line]*] [CR]*
 
-line: NUMBER statement [/":" statement]*
+line: NUMBER statement-list
 
-statement : "def" id /"(" id /")" /"=" expr
+statement-list : statement [":" statement-list]
-| "dim" id-expr [/"," id-expr]*
-| "end" | "stop"
-| "gosub" expr
-| "goto" expr
-| "on" expr ("gosub" | "goto") expr [/"," expr]*
-| "if" expr /"then" (statement | expr) [/"else" (statement | expr)]
-| "input" [print-list /";"] id [/"," id]*
-| [/"let"] id-expr "=" expr
-| "print" [print-list]
-| "return"
-| "for" id /"=" expr /"to" expr [/"step" expr]
-| "next" [id]
 
-print-list : expr [[";"] [print-list]]
+statement : "END"
+| "GOSUB" NUMBER
+| "GOTO" expr
+| "IF" expr "THEN" (statement | expr) ["ELSE" (statement | expr)]
+| "INPUT" [print-list ";"] ID
+| ID "=" expr ; change: make "LET" opt
+| "PRINT" print-list
+| "RETURN"
 
-expr : comp-expr [("and" | "or") expr]
+print-list : [expr [";" [print-list]]]
+
+expr : comp-expr [("AND" | "OR") expr]
 
 comp-expr : sum [("=" | ">" | ">=" | "<" | "<=" | "<>") comp-expr]
 
-sum : [sum ("+" | "-")] product
+sum : product [("+" | "-") sum]
 
-product : [product ("*" | "/")] power
+product : value [("*" | "/") product]
 
-power : value [/"^" value]
+expr-list : expr ["," expr-list]*
 
-@value : id-val
+value : ID ["(" expr-list ")"]
-| id-expr
+| "(" expr ")"
-| /"(" expr /")"
-| number
 | STRING
+| NUMBER
 
-id-expr : id [/"(" expr [/"," expr]* /")"]
-
-@id : ID
-
-id-val : ["-"] id-expr
-
-number : ["-"] NUMBER

beautiful-racket/br/demo/basic/sinewave.bas

@@ -1,19 +1,6 @@
 #lang br/demo/basic
 
-10 PRINT TAB(30);"SINE WAVE"
+1 A = 2
-20 PRINT TAB(15);"CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
+10 PRINT A < 2
-30 PRINT: PRINT: PRINT: PRINT: PRINT
+12 C$ = "string thing"
-40 REMARKABLE PROGRAM BY DAVID AHL
+15 PRINT A;: PRINT C$
-50 B=0
-100 REM  START LONG LOOP
-110 FOR T=0 TO 40 STEP .25
-120 A=INT(26+25*SIN(T))
-130 PRINT TAB(A);
-140 IF B=1 THEN 180
-150 PRINT "CREATIVE"
-160 B=1
-170 GOTO 200
-180 PRINT "COMPUTING"
-190 B=0
-200 NEXT T
-999 END

beautiful-racket/br/demo/basic/tabs.bas

@@ -1,5 +0,0 @@
-#lang br/demo/basic
-
-5 print 30; "foo"
-10 PRINT TAB(10);"*";
-20 PRINT TAB(15);"*";

beautiful-racket/br/demo/basic/tokenizer.rkt

@@ -1,34 +1,33 @@
 #lang br
 (require parser-tools/lex parser-tools/lex-sre
-         brag/support
+         br/ragg/support
          racket/string)
 (provide tokenize)
 
 (define-lex-abbrevs
   (natural (repetition 1 +inf.0 numeric))
-;; don't lex the leading "-": muddles "-X" and "Y-X"
+  (number (union (seq (? "-") natural)
-  (number (union (seq natural)
+                 (seq (? "-") (? natural) (seq "." natural))))
-                 (seq (? natural) (seq "." natural))))
   (quoted-string (seq "\"" (repetition 0 +inf.0 (char-complement "\"")) "\"")))
 
 (define (tokenize input-port)
   (define (next-token)
     (define get-token
-      (lexer-src-pos
+      (lexer
        [(eof) eof]
-       [(seq "/*" (complement (seq any-string "*/" any-string)) "*/") (get-token input-port)]
+       [(union #\tab #\space
-       [(union #\tab #\space #\newline
+               (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
-               (seq number " REM" (repetition 0 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
+       [(seq #\newline (repetition 0 +inf.0 whitespace)) (token 'CR "cr")]
-       [(union "PRINT" "print" "FOR" "for" "TO" "to" "STEP" "step" "IF" "if"
+       [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
-               "GOTO" "goto" "INPUT" "input" "LET" "let" "NEXT" "next"
+               "INPUT" "LET" "NEXT"  "RETURN"
-               "RETURN" "return" "CLEAR" "clear" "LIST" "list" "RUN" "run"
+               "CLEAR" "LIST" "RUN" "END"
-               "END" "end" "THEN" "then" "ELSE" "else" "GOSUB" "gosub"
+               "THEN" "ELSE" "GOSUB" "AND" "OR"
-               "AND" "and" "OR" "or" "STOP" "stop" "LET" "let" "DEF" "def" "DIM" "dim" "ON" "on"
+               ";" "=" "(" ")" "+" "-" "*" "/"
-               ";" "=" "(" ")" "+" "-" "*" "/" "^"
+               "<=" ">=" "<>" "<" ">" "=" ":") lexeme]
-               "<=" ">=" "<>" "<" ">" "=" ":" ",") (string-downcase lexeme)]
+       [(union ",") (get-token input-port)]
        [number (token 'NUMBER (string->number lexeme))]
-       [(seq upper-case (repetition 0 +inf.0 (or upper-case numeric)) (? "$")) (token 'ID (string->symbol lexeme))]
+       [(seq (repetition 1 +inf.0 upper-case) (? "$")) (token 'ID (string->symbol lexeme))]
+       [upper-case (token 'UPPERCASE (string->symbol lexeme))]
        [quoted-string (token 'STRING (string-trim lexeme "\""))]))
     (get-token input-port))  
   next-token)
-

beautiful-racket/br/demo/bf/bf-atsign.rkt

@@ -1,3 +1,3 @@
 #lang reader "bf-reader.rkt"
 Greatest language ever!
-++++-+++-++-++[>++++-+++-++-++<-]>.[
+++++++++[>++++++++<-]>.

beautiful-racket/br/demo/bf/bf-expander-imperative.rkt

@@ -1,39 +0,0 @@
-#lang br/quicklang
- 
-(define-macro (bf-module-begin PARSE-TREE)
-  #'(#%module-begin
-     PARSE-TREE))
-(provide (rename-out [bf-module-begin #%module-begin]))
-
-(define-macro (bf-program OP-OR-LOOP-ARG ...)
-  #'(void OP-OR-LOOP-ARG ...))
-(provide bf-program)
-
-(define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
-  #'(until (zero? (current-byte))
-           OP-OR-LOOP-ARG ...))
-(provide loop)
-
-(define-macro-cases op
-  [(op ">") #'(gt)]
-  [(op "<") #'(lt)]
-  [(op "+") #'(plus)]
-  [(op "-") #'(minus)]
-  [(op ".") #'(period)]
-  [(op ",") #'(comma)])
-(provide op)
-
-(define arr (make-vector 30000 0))
-(define ptr 0)
-
-(define (current-byte) (vector-ref arr ptr))
-
-(define (set-current-byte! val) (vector-set! arr ptr val))
-
-(define (gt) (set! ptr (add1 ptr)))
-(define (lt) (set! ptr (sub1 ptr)))
-(define (plus) (set-current-byte! (add1 (current-byte))))
-(define (minus) (set-current-byte! (sub1 (current-byte))))
-(define (period) (write-byte (current-byte)))
-(define (comma) (set-current-byte! (read-byte)))
-

beautiful-racket/br/demo/bf/bf-expander.rkt

@@ -1,60 +1,36 @@
-#lang br/quicklang
+#lang br
 
-(define-macro (bf-module-begin PARSE-TREE)
+(define #'(bf-module-begin _PARSE-TREE ...)
   #'(#%module-begin
-     PARSE-TREE))
+     _PARSE-TREE ...)) 
-(provide (rename-out [bf-module-begin #%module-begin]))
+(provide (rename-out [bf-module-begin #%module-begin])
+         #%top-interaction)
 
-(define (fold-funcs apl bf-funcs)
+(define #'(bf-program _OP-OR-LOOP ...)
-  (for/fold ([current-apl apl])
+  #'(begin _OP-OR-LOOP ...))
-            ([bf-func (in-list bf-funcs)])
-    (apply bf-func current-apl)))
-
-(define-macro (bf-program OP-OR-LOOP-ARG ...)
-  #'(begin
-      (define first-apl (list (make-vector 30000 0) 0))
-      (void (fold-funcs first-apl (list OP-OR-LOOP-ARG ...)))))
 (provide bf-program)
 
-(define-macro (loop "[" OP-OR-LOOP-ARG ... "]")
+(define-cases #'op
-  #'(lambda (arr ptr)
+  [#'(op ">") #'(move-pointer 1)]
-      (for/fold ([current-apl (list arr ptr)])
+  [#'(op "<") #'(move-pointer -1)]
-                ([i (in-naturals)]
+  [#'(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
-                 #:break (zero? (apply current-byte
+  [#'(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
-                                       current-apl)))
+  [#'(op ".") #'(write-byte (get-current-byte))]
-        (fold-funcs current-apl (list OP-OR-LOOP-ARG ...)))))
+  [#'(op ",") #'(set-current-byte! (read-byte))])
-(provide loop)
-
-(define-macro-cases op
-  [(op ">") #'gt]
-  [(op "<") #'lt]
-  [(op "+") #'plus]
-  [(op "-") #'minus]
-  [(op ".") #'period]
-  [(op ",") #'comma])
 (provide op)
 
-(define (current-byte arr ptr) (vector-ref arr ptr))
+(define bf-vector (make-vector 30000 0))
+(define bf-pointer 0)
 
-(define (set-current-byte arr ptr val)
+(define (move-pointer how-far)
-  (vector-set! arr ptr val)
+  (set! bf-pointer (+ bf-pointer how-far)))
-  arr)
 
-(define (gt arr ptr) (list arr (add1 ptr)))
+(define (get-current-byte)
-(define (lt arr ptr) (list arr (sub1 ptr)))
+  (vector-ref bf-vector bf-pointer))
-
+(define (set-current-byte! val)
-(define (plus arr ptr)
+  (vector-set! bf-vector bf-pointer val))
-  (list (set-current-byte arr ptr (add1 (current-byte arr ptr)))
-        ptr))
-
-(define (minus arr ptr)
-  (list (set-current-byte arr ptr (sub1 (current-byte arr ptr)))
-        ptr))
-
-(define (period arr ptr)
-  (write-byte (current-byte arr ptr))
-  (list arr ptr))
-
-(define (comma arr ptr)
-  (list (set-current-byte arr ptr (read-byte)) ptr))
 
+(define #'(loop "[" _OP-OR-LOOP ... "]")
+  #'(until (zero? (get-current-byte))
+           _OP-OR-LOOP ...))
+(provide loop)

beautiful-racket/br/demo/bf/bf-parser.rkt

@@ -1,4 +1,4 @@
-#lang brag
+#lang br/ragg
 bf-program : (op | loop)*
 op : ">" | "<" | "+" | "-" | "." | ","
 loop : "[" (op | loop)* "]"

beautiful-racket/br/demo/bf/bf-reader.rkt

@@ -1,20 +1,21 @@
-#lang br/quicklang
+#lang br
-(require "bf-parser.rkt")
+(require parser-tools/lex br/ragg/support)
-
+(define (tokenize input-port)
-(define (read-syntax path port)
-  (define parse-tree (parse path (tokenize port)))
-  (define module-datum `(module bf-mod br/demo/bf/bf-expander
-                          ,parse-tree))
-  (datum->syntax #f module-datum))
-(provide read-syntax)
-
-(require parser-tools/lex brag/support)
-(define (tokenize port)
   (define (next-token)
-    (define our-lexer
+    (define get-token
       (lexer
-       [(eof) eof]
        [(char-set "><-.,+[]") lexeme]
-       [any-char (next-token)]))
+       [(char-complement (char-set "><-.,+[]")) 
-    (our-lexer port))  
+         (token 'OTHER #:skip? #t)]
+       [(eof) eof]))
+    (get-token input-port))  
   next-token)
+
+(require "bf-parser.rkt")
+(define (read-syntax source-path input-port)
+  (define parse-tree (parse source-path (tokenize input-port)))
+  (strip-context
+    (inject-syntax ([#'PARSE-TREE parse-tree])
+                  #'(module bf-mod br/demo/bf/bf-expander
+                      PARSE-TREE))))
+(provide read-syntax)

beautiful-racket/br/demo/bf/test-tokenizer.rkt

@@ -1,5 +1,5 @@
 #lang br
-(require parser-tools/lex brag/support)
+(require parser-tools/lex br/ragg/support)
 
 (define+provide (tokenize ip)
   (define get-token

beautiful-racket/br/demo/chip8.rkt

@@ -3,7 +3,7 @@
 ; http://devernay.free.fr/hacks/chip8/C8TECH10.HTM
 ; http://mattmik.com/files/chip8/mastering/chip8.html
 
-(define (split-bytes val)
+(define (explode-bytes val)
   (cond
     [(zero? val) (list 0)]
     [else
@@ -17,95 +17,60 @@
 
 (module+ test
   (require rackunit)
-  (check-equal? (split-bytes #x2B45) (list #x2 #xB #x4 #x5))
+  (check-equal? (explode-bytes #x2B45) (list #x2 #xB #x4 #x5))
-  (check-equal? (split-bytes #xCD) (list #xC #xD))
+  (check-equal? (explode-bytes #xCD) (list #xC #xD))
-  (check-equal? (split-bytes #xA) (list #xA))
+  (check-equal? (explode-bytes #xA) (list #xA))
-  (check-equal? (split-bytes #x0) (list #x0)))
+  (check-equal? (explode-bytes #x0) (list #x0)))
 
-(define (join-bytes bytes)
+(define (glue-bytes bytes)
   (for/sum ([b (in-list (reverse bytes))]
             [i (in-naturals)])
            (* b (expt 16 i))))
 
 (module+ test
-  (check-equal? #x2B45 (join-bytes (list #x2 #xB #x4 #x5)))
+  (check-equal? #x2B45 (glue-bytes (list #x2 #xB #x4 #x5)))
-  (check-equal? #xCD (join-bytes (list #xC #xD)))
+  (check-equal? #xCD (glue-bytes (list #xC #xD)))
-  (check-equal? #xA (join-bytes (list #xA)))
+  (check-equal? #xA (glue-bytes (list #xA)))
-  (check-equal? #x0 (join-bytes (list #x0))))
+  (check-equal? #x0 (glue-bytes (list #x0))))
 
-(define-macro (define-memory-vector ID [FIELD LENGTH SIZE] ...)
+(define-syntax (define-memory-vector stx)
-  (with-pattern
+  (syntax-case stx ()
-   ([(PREFIXED-ID ...)  (prefix-id #'ID "-" #'(FIELD ...))]
+    [(_ ID [FIELD LENGTH SIZE] ...)
-    [(PREFIXED-ID-REF ...) (suffix-id #'(PREFIXED-ID ...) "-ref")]
+     (with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))]
-    [(PREFIXED-ID-SET! ...) (suffix-id #'(PREFIXED-ID ...) "-set!")]
+                   [(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))]
-    [(FIELD-OFFSET ...) (reverse (cdr
+                   [(FIELD-OFFSET ...) (reverse (cdr
-                                  (for/fold ([accum-stxs (list #'0)])
+                                                 (for/fold ([offsets '(0)])
-                                            ([len-size-stx (in-list (syntax->list #'((LENGTH SIZE) ...)))])
+                                                           ([len (in-list (syntax->list #'(LENGTH ...)))]
-                                    (cons (with-pattern
+                                                            [size (in-list  (syntax->list #'(SIZE ...)))])
-                                           ([accum (car accum-stxs)]
+                                                   (cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))])
-                                            [(len size) len-size-stx])
+       #'(begin
-                                           #'(+ (* len size) accum)) accum-stxs))))])
+           (define ID (make-vector (+ (* LENGTH SIZE) ...)))
-   #'(begin
+           (define (ID-FIELD-REF idx)
-       (define ID (make-vector (+ (* LENGTH SIZE) ...)))
+             (unless (< idx LENGTH)
-       (define (PREFIXED-ID-REF idx)
+               (raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx))
-         (unless (< idx LENGTH)
+             (glue-bytes
-           (raise-argument-error 'PREFIXED-ID-REF (format "index less than field length ~a" LENGTH) idx))
+              (for/list ([i (in-range SIZE)])
-         (join-bytes
+                        (vector-ref ID (+ FIELD-OFFSET i idx)))))
-          (for/list ([i (in-range SIZE)])
+           ...
-                    (vector-ref ID (+ FIELD-OFFSET i idx)))))
+           (define (ID-FIELD-SET! idx val)
-       ...
+             (unless (< idx LENGTH)
-       (define (PREFIXED-ID-SET! idx val)
+               (raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx))
-         (unless (< idx LENGTH)
+             (unless (< val (expt 16 SIZE))
-           (raise-argument-error 'PREFIXED-ID-SET! (format "index less than field length ~a" LENGTH) idx))
+               (raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
-         (unless (< val (expt 16 SIZE))
+             (for ([i (in-range SIZE)]
-           (raise-argument-error 'PREFIXED-ID-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
+                   [b (in-list (explode-bytes val))])
-         (for ([i (in-range SIZE)]
+                  (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))]))
-               [b (in-list (split-bytes val))])
-              (vector-set! ID (+ FIELD-OFFSET i idx) b))) ...)))
 
-(define-memory-vector chip8 
+(define-memory-vector chip 
   [opcode 1 2] ; two bytes
   [memory 4096 1] ; one byte per
   [V 16 1] ; one byte per
-  [I 2 1] ; index register, 0x000 to 0xFFF (1.5 bytes)
+  [I 3 1] ; index register, 0x000 to 0xFFF
-  [pc 2 1] ; program counter, 0x000 to 0xFFF (1.5 bytes)
+  [pc 3 1] ; program counter, 0x000 to 0xFFF
   [gfx (* 64 32) 1] ; pixels
   [delay_timer 1 1]
   [sound_timer 1 1]
   [stack 16 2] ; 2 bytes each
-  [sp 1 2] ; stack pointer
+  [sp 1 1] ; stack pointer
   [key 16 1]) ; keys
 
-;; Set up render system and register input callbacks
-;(setup-graphics chip8)
-;(setup-input chip8)
-
-;; Initialize the Chip8 system and load the game into the memory
-#;(define (initialize c)
-  ;; Initialize registers and memory once
-  )
-
-;(initialize chip8)
-;(load-game chip8 "pong")
-
-
-#;(define (emulate-cycle c)
-;    // Fetch Opcode
-;  // Decode Opcode
-;  // Execute Opcode
-; 
-;  // Update timers
-
-    )
-
-;; Emulation loop
-#;(let loop ()
-  ;; Emulate one cycle
-  (emulate-cycle chip8)
-  ;; If the draw flag is set, update the screen
-  (when (draw-flag? chip8)
-    (draw-graphics chip8))
-  
-  ;; Store key press state (Press and Release)
-  (set-keys chip8)
-  (loop))

beautiful-racket/br/demo/funstacker-h2.rkt

@@ -1,33 +0,0 @@
-#lang br/quicklang
-
-(define (read-syntax path port)
-  (define args (port->lines port))
-  (define arg-datums (filter-not void? (format-datums '~a args)))
-  (define module-datum `(module stacker-mod br/demo/funstacker
-                          (nestify null ,@arg-datums)))
-  (datum->syntax #f module-datum))
-(provide read-syntax)
-
-(define-macro (stacker-module-begin HANDLE-ARGS-EXPR)
-  #'(#%module-begin
-     (display (first HANDLE-ARGS-EXPR))))
-(provide (rename-out [stacker-module-begin #%module-begin]))
-
-(require (for-syntax sugar/debug))
-(define-macro-cases nestify
-  [(nestify ARG0) #'ARG0]
-  [(nestify ARG0 ARG1 ARG ...) #'(nestify (h3 ARG0 ARG1) ARG ...)])
-(provide nestify)
-     
-(define (h3 stack arg)
-  (cond
-    [(number? arg) (cons arg stack)]
-    [(or (equal? * arg) (equal? + arg))
-     (define op-result (arg (first stack) (second stack)))
-     (cons op-result (drop stack 2))]))
-
-(provide + * null)
-
-(module+ test 
-  (require rackunit)
-  #;(check-equal? (with-output-to-string (λ () (dynamic-require "funstacker-test.rkt" #f))) "36"))