working files

README.md

@@ -1,5 +1,15 @@
 **beautiful-racket**
 
-Resources for the “Beautiful Racket” book 
+Resources for the upcoming “Beautiful Racket” book, including:
+
+* `#lang br` teaching language
+
+
+Installation:
 
 `raco pkg install beautiful-racket`
+
+
+Update:
+
+`raco pkg update beautiful-racket`

br/datum.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax) br/define)
+(provide (all-defined-out))
+
+;; read "foo bar" the same way as "(foo bar)" 
+;; other "bar" is dropped, which is too astonishing
+(define (string->datum str)
+  (let ([result (read (open-input-string (format "(~a)" str)))])
+    (if (= (length result) 1)
+        (car result)
+        result)))
+
+(define-syntax format-datum
+  (λ(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 (list arg ...))))])))
+
+
+(module+ test
+  (require rackunit)
+  (check-equal? (string->datum "foo") 'foo)
+  (check-equal? (string->datum "(foo bar)") '(foo bar))
+  (check-equal? (string->datum "foo bar") '(foo bar))
+  (check-equal? (string->datum "42") 42)
+  (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))

br/debug.rkt

@@ -0,0 +1,17 @@
+#lang racket/base
+(require (for-syntax racket/base racket/syntax))
+(provide (all-defined-out))
+
+(define-syntax (report stx)
+  (syntax-case stx ()
+    [(_ expr) #'(report expr expr)]
+    [(_ expr name)
+     #'(let ([expr-result expr]) 
+         (eprintf "~a = ~v\n" 'name expr-result)
+         expr-result)]))
+
+(define-syntax-rule (define-multi-version multi-name name)
+  (define-syntax-rule (multi-name x (... ...))
+    (begin (name x) (... ...))))
+
+(define-multi-version report* report)

br/define.rkt

@@ -0,0 +1,41 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse))
+(provide (all-defined-out))
+
+(define-syntax (br:define stx)
+  (define-syntax-class syntaxed-id
+    #:literals (syntax)
+    #:description "id in syntaxed form"
+    (pattern (syntax name:id)))
+  
+  (syntax-parse stx
+    #:literals (syntax)
+    [(_ (syntax (id pat-arg ...)) (syntax body ...)) ; (define #'(foo arg) #'(+ arg arg))
+     #'(define-syntax-rule (id pat-arg ...) body ...)]
+    
+    [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
+     #'(define-syntax sid.name (make-rename-transformer sid2))]
+    
+    [(_ (sid:syntaxed-id stx-arg ...) expr ...)  ; (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 ...) expr ...)) ; (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 ...)))
+     #'(define-syntax (sid.name stx-arg ...) expr ...)]
+    
+    [(_ args ...) #'(define args ...)]))
+
+(module+ test
+  (require rackunit)
+  (br:define #'plus (λ(stx) #'+))
+  (br:define #'plusser #'plus)
+  (br:define #'(times arg) #'(* arg arg))
+  (br:define #'timeser #'times)
+  (check-equal? (plus 42) +)
+  (check-equal? plusser +)
+  (check-equal? (plusser 42) +)
+  (check-equal? (times 10) 100)
+  (check-equal? (timeser 12) 144)
+  ;; todo: error from define not trapped by check-exn 
+  #;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*))))

br/ex/nothing/nothing-invoked-as-reader.rkt

@@ -0,0 +1 @@
+#lang reader (submod "nothing.rkt" reader)

br/ex/nothing/nothing-invoked-as-semantics.rkt

@@ -0,0 +1 @@
+#lang s-exp "nothing.rkt"

br/ex/nothing/nothing.rkt

@@ -0,0 +1,39 @@
+#lang racket
+(provide (all-from-out racket))
+
+(module reader syntax/module-reader
+  br/ex/nothing/nothing)
+
+#|
+
+#lang racket
+(provide (all-from-out racket))
+
+(module reader racket/base
+  (provide read read-syntax))
+
+|#
+
+#|
+
+(module nothing racket
+  (provide (all-from-out racket))
+  
+  (module reader syntax/module-reader
+    br/ex/nothing))
+
+|#
+
+#|
+
+#lang racket
+
+(module reader syntax/module-reader
+  #:language '(submod br/ex/nothing semantics))
+
+(module semantics racket
+  (provide (all-from-out racket)))
+
+(sleep 100000)
+
+|#

br/ex/simples/expander-only/expander-invoked.rkt

@@ -0,0 +1,10 @@
+#lang s-exp "expander.rkt"
+
+"asdf"
+
+
+41
+
+1+2i
+
+;; but not foo

br/ex/simples/expander-only/expander.rkt

@@ -0,0 +1,11 @@
+#lang br
+(provide (rename-out [simple-module-begin #%module-begin])
+          #%datum #%top-interaction)
+(define #'(simple-module-begin expr ...)
+  #'(#%module-begin
+     (define lines (list expr ...))
+     (display (format "Expressions = ~a" (length lines)))
+     (define numbers (filter number? lines))
+     (unless (zero? (length numbers))
+       (displayln (format ", numbers = ~a" (length numbers)))
+       (apply + numbers))))

br/ex/simples/rapl/rapl.rkt

@@ -0,0 +1,61 @@
+#lang br
+(require racket/function)
+(provide (except-out (all-from-out br) + *)
+         (rename-out [my+ +] [my* *]) ⌊)
+
+(define (⌊ largs rargs)
+  (let ([lenlargs (length largs)]
+        [lenrargs (length rargs)])
+    (cond
+      [(zero? lenlargs)
+       (map (compose1 inexact->exact floor) rargs)]
+      [(= lenlargs lenrargs)
+       (map min
+            largs rargs)])))
+
+(define (my* largs rargs)
+  (let ([lenlargs (length largs)]
+        [lenrargs (length rargs)])
+    (cond
+      [(= lenlargs lenrargs)
+       (map * largs rargs)]
+      [(= 1 lenlargs)
+       (map (curry * (car largs)) rargs)]
+      [(= 1 lenrargs)
+       (my* rargs largs)]
+      [else
+       (error 'length-error)])))
+
+(define (my+ largs rargs)
+  (let ([lenlargs (length largs)]
+        [lenrargs (length rargs)])
+    (cond
+      [(= lenlargs lenrargs)
+       (map + largs rargs)]
+      [(= 1 lenlargs)
+       (map (curry + (car largs)) rargs)]
+      [(= 1 lenrargs)
+       (my+ rargs largs)]
+      [else
+       (error 'length-error)])))
+
+(module reader br
+  (provide read-syntax)
+  (define (read-syntax src-path src-port)
+    (define operators '(+ ⌊ *))
+    (define src-exprs (for/list ([ln (in-lines src-port)]
+                                 #:when (regexp-match #px"\\w" ln))
+                                (format-datum '(begin ~a) ln)))
+    (with-syntax ([(src-expr ...) src-exprs])
+    (syntax->datum #'(module rapl "rapl.rkt"
+        (displayln 'src-expr) ...)))))
+
+
+
+#;(module+ test
+    (require rackunit)
+    (check-equal? (+ '(4) '(7)) '(11))
+    (check-equal? (+ '(3) '(2 4 11 7 5)) '(5 7 14 10 8))
+    (check-equal? (+ '(6 3 8 1) '(3)) '(9 6 11 4))
+    (check-equal? (+ '(6 3 8 1) '(3 6 1 8)) '(9 9 9 9))
+    (check-exn exn:fail? (λ _ (+ '(6 8 1) '(3 6 1 8)))))

br/ex/simples/rapl/rapltest.rkt

@@ -0,0 +1,7 @@
+#lang reader (submod "rapl.rkt" reader)
+  
+1 3 3 7 * 8.41
+
+⌊ 8.41
+
+5 ⌊ 8.41

br/ex/simples/reader-only/reader-invoked.rkt

@@ -0,0 +1,3 @@
+#lang reader "reader.rkt"
+
+This is a terrible idea, and I should know because I invented it.

br/ex/simples/reader-only/reader.rkt

@@ -0,0 +1,9 @@
+#lang br
+(provide read-syntax)
+
+(define (read-syntax src in)
+  (syntax-let ([#'src-str (port->string in)])
+              #'(module no-name racket
+                  (define (scramble str)
+                    (list->string (shuffle (string->list str))))
+                  (regexp-replace* #px"\\w+" src-str scramble))))

br/ex/simples/stack compiler/stack-compiler-invoked.rkt

@@ -0,0 +1,3 @@
+#lang reader "stack-compiler.rkt"
+
+(* (/ 25 14 (expt 5 2)) (/ 2 3 1) (* 10 12 15))

br/ex/simples/stack compiler/stack-compiler.rkt

@@ -0,0 +1,33 @@
+#lang br
+
+(provide #%top-interaction) ; activates the REPL
+
+;; reader goes first and
+;; 1) converts surface syntax into Rackety expressions (wrapping in `(inst ...)`)
+;; 2) creates a module specifying semantics source (in this case, same module)
+(provide read-syntax)
+(define (read-syntax src-path src-input-port)
+  (define expr-datums (for/list ([src-line (in-lines src-input-port)]
+                                 #:when (regexp-match #px"\\w" src-line))
+                                (format-datum '~a src-line)))
+  (syntax-let ([#'(expr-stx ...) expr-datums]) ; ok to bind with non-syntax
+              #'(module stack-compiler-module "stack-compiler.rkt" 
+                  expr-stx ...)))
+
+
+;; semantics always start with #%module-begin, which unwraps the content of the module and rewraps it
+(provide (rename-out [stack-module-begin #%module-begin]))
+(define #'(stack-module-begin expr ...)
+  #'(#%module-begin
+     (stackify (quote expr)) ...))
+
+
+(define (stackify quoted-expr)
+  (define pushes
+    (let loop ([x quoted-expr])
+      (cond
+        [(list? x)
+         (match-define (list op args ...) x)
+         (append (make-list (sub1 (length args)) op) (flatten (map loop args)))]
+        [else x])))
+  (for-each displayln (map (λ(p) (format "push ~a" p)) (reverse pushes))))

br/ex/simples/stack/stack-invoked.rkt

@@ -0,0 +1,21 @@
+#lang reader "stack.rkt"
+
+push 15
+push 12
+push 10
+push *
+push *
+push 1
+push 3
+push 2
+push /
+push /
+push 2
+push 5
+push expt
+push 14
+push 25
+push /
+push /
+push *
+push *

br/ex/simples/stack/stack.rkt

@@ -0,0 +1,62 @@
+#lang br
+
+(provide #%top-interaction) ; activates the REPL
+
+;; reader goes first and
+;; 1) converts surface syntax into Rackety expressions (wrapping in `(inst ...)`)
+;; 2) creates a module specifying semantics source (in this case, same module)
+(provide read-syntax)
+(define (read-syntax src-path src-input-port)
+  (define inst-datums (for/list ([src-line (in-lines src-input-port)]
+                                #:when (regexp-match #px"\\w" src-line))
+                              (format-datum '(inst ~a) src-line)))
+  (syntax-let ([#'(inst-stx ...) inst-datums]) ; ok to bind with non-syntax
+              #'(module stack-lang-module "stack.rkt" 
+                  inst-stx ...)))
+
+(define stack empty)
+
+;; semantics always start with #%module-begin, which unwraps the content of the module and rewraps it
+(provide (rename-out [stack-module-begin #%module-begin]))
+(define #'(stack-module-begin instructions ...)
+  #'(#%module-begin
+     instructions ...
+     (first stack)))
+
+
+;; then file is processed like a normal Racket file.
+
+(provide inst)
+(define (inst . args)
+  (if (<= 1 (length args) 2)
+      (let ([proc (first args)])
+        (apply proc (cdr args)))
+      (void)))
+
+
+(provide push)
+(define (push arg)
+  (display "push: ")
+  (cond
+    [(procedure? arg)
+     (displayln (format "got ~a, replacing ~a and ~a with result"  arg (first stack) (second stack) ))
+     (set! stack (cons (arg (first stack) (second stack)) (cddr stack)))]
+    [else (displayln (format "storing value ~a" arg))
+          (set! stack (cons arg stack))])
+  (displayln stack))
+
+;; exercises
+
+(provide pop)
+(define (pop)
+  (display "pop: ")
+  (displayln (format "got ~a" (car stack)))
+  (set! stack (cdr stack))
+  (displayln stack))
+
+(provide swap)
+(define (swap)
+  (display "swap: ")
+  (displayln (format "~a and ~a" (first stack) (second stack)))
+  (set! stack (list* (second stack) (first stack) (cddr stack)))
+  (displayln stack))

br/ex/simples/stack/stacker/info.rkt

@@ -0,0 +1,2 @@
+#lang info
+(define collection "stacker")

br/ex/simples/stack/stacker/stacker-lang.rkt

@@ -0,0 +1,35 @@
+#lang br
+(define (read-syntax src-path src-port)
+  (define src-strs (port->lines src-port))
+  (define (make-datum str) (format-datum '(dispatch ~a) str))
+  (define src-exprs (map make-datum src-strs))
+  (inject-syntax ([#'(list src-expr ...) src-exprs])
+                 #'(module stacker-mod "stacker-lang.rkt"
+                     src-expr ...)))
+(provide read-syntax)
+
+(define #'(stacker-module-begin reader-line ...)
+  #'(#%module-begin
+     reader-line ...
+     (display (first stack))))
+(provide (rename-out [stacker-module-begin #%module-begin]))
+
+(define stack (list 0 0))
+(define (push num) (set! stack (cons num stack)))
+
+(define (dispatch arg-1 [arg-2 #f])
+  (cond
+    [(number? arg-2) (push arg-2)]
+    [else
+     (define op arg-1)
+     (define op-result (op (first stack) (second stack)))
+     (set! stack (cons op-result (drop stack 2)))]))
+
+#;(define dispatch
+    (case-lambda
+      [(push num) (push num)]
+      [(stack-op)
+       (define op-result (stack-op (first stack) (second stack)))
+       (set! stack (cons op-result (drop stack 2)))]))
+
+(provide #%top-interaction)

br/ex/simples/stack/stacker/stacker-test.rkt

@@ -0,0 +1,6 @@
+#lang reader "stacker-lang.rkt"
+push 4
+push 8
++
+push 3
+*

br/info.rkt

@@ -0,0 +1,2 @@
+#lang info
+(define test-omit-paths 'all)

br/load.rkt

@@ -0,0 +1,26 @@
+#lang racket
+(provide (except-out (all-from-out racket) #%module-begin)
+         (rename-out [loader-module-begin #%module-begin]))
+
+#|
+
+br/load makes it possible to invoke a quick #lang by its pathname (without installing it as a collection)
+
+#lang br/load "path.rkt"
+
+Should simply delegate the reader & semantics.
+
+|#
+
+(define-syntax-rule (loader-module-begin loadpath expr ...)
+  (#%module-begin
+   (module loader-module loadpath
+     expr ...)
+   (require 'loader-module)
+   
+   (module reader racket/base
+     (require '(submod loadpath reader))
+     (provide (all-from-out '(submod loadpath reader))))))
+
+(module reader syntax/module-reader
+  br/load)

br/main.rkt

@@ -0,0 +1,19 @@
+#lang racket/base
+(require racket/provide racket/list racket/string racket/format racket/match racket/port
+         br/define br/syntax br/datum br/debug
+         (for-syntax racket/base racket/syntax br/syntax br/define))
+(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)
+         (for-syntax (all-from-out racket/base racket/syntax br/syntax))
+         (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
+
+(module reader syntax/module-reader
+  #:language 'br)

br/scribble-xexpr.rkt

@@ -0,0 +1,40 @@
+#lang at-exp br
+(require scribble/manual scribble/core txexpr)
+(provide scribble->xexpr)
+
+(define (style->attrs s style-accessor)
+  (let* ([style-datum (style-accessor s)])
+    (if (style? style-datum) ; either style struct, or simple symbol name
+        `((style ,(~a (style-name style-datum)))
+          (properties ,(string-join (map ~a (style-properties style-datum)) " ")))
+        `((style ,(~a style-datum))))))
+
+
+;; Unfortunately there seems to be no generic way of fetching the style & elements from a Scribble structure
+;; the specific struct accessors must be used.
+(define #'structure->txexpr
+  (λ(stx)
+    (syntax-match stx
+                  [#'(_ structure-name elem-name id)
+                   (syntax-let ([#'structure-name-elem-name (format-id stx "~a-~a" #'structure-name #'elem-name)]
+                                [#'structure-name-style (format-id stx "~a-style" #'structure-name)])
+                               #'(let* ([elem-raw (structure-name-elem-name id)]
+                                        [elems (map scribble->xexpr (if (list? elem-raw)
+                                                                        (flatten elem-raw)
+                                                                        (list elem-raw)))])
+(list* 'structure-name (style->attrs id structure-name-style) elems)))])))
+
+(define (scribble->xexpr s)
+  (cond
+    [(nested-flow? s) (structure->txexpr nested-flow blocks s)]
+    [(paragraph? s) (structure->txexpr paragraph content s)]
+    [(element? s) (structure->txexpr element content s)]
+    [else s]))
+
+(module+ test
+  (require rackunit)
+  (define-simple-check (check-sx? s)
+    (check-true (txexpr? (scribble->xexpr s))))
+  (check-sx? @racketblock[(list +)])
+  (check-sx? @racket[(list +)])
+  (check-sx? @code{(list +)}))

br/syntax.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse #;racket/syntax) #;racket/syntax)
+(provide (all-defined-out))
+
+(define-syntax (syntax-match stx)
+  (syntax-case stx (syntax)
+    [(_ stx-arg [(syntax pattern) body ...] ...)
+     #'(syntax-case stx-arg ()
+         [pattern body ...] ...)]))
+
+(define-syntax (add-syntax stx)
+  (syntax-case stx (syntax)
+    [(_ ([(syntax sid) sid-stx] ...) body ...)
+     #'(with-syntax ([sid sid-stx] ...) body ...)]))
+
+(define-syntax syntax-let (make-rename-transformer #'add-syntax))
+
+(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
+
+#;(define-syntax syntax-variable (make-rename-transformer #'format-id))

info.rkt

@@ -0,0 +1,6 @@
+#lang info
+(define collection 'multi)
+
+(define version "0.01")
+(define deps '("base"))
+(define build-deps '("racket-doc"))