unification

.travis.yml

@@ -33,7 +33,8 @@ before_install:
 
 script:
  - cd ..   # Travis did a cd into the dir. Back up, for the next:
- # manually install `beautiful-racket-lib` to catch most recent updates
- - travis_retry raco pkg install --deps search-auto git://github.com/mbutterick/beautiful-racket-lib
- - travis_retry raco pkg install --deps search-auto --link beautiful-racket
+ # don't rely on package server
+ - travis_retry raco pkg install --deps search-auto git://github.com/mbutterick/beautiful-racket/beautiful-racket-lib
+ - raco test -p beautiful-racket-lib
+ - travis_retry raco pkg install --deps search-auto --link git://github.com/mbutterick/beautiful-racket/beautiful-racket
  - raco test -p beautiful-racket

README.md

@@ -3,6 +3,10 @@ beautiful-racket [![Build Status](https://travis-ci.org/mbutterick/beautiful-rac
 
 Resources for the upcoming “Beautiful Racket” book, including:
 
+* `#lang br` teaching language
+ 
+* supporting modules
+
 * sample languages
 
 

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

@@ -0,0 +1,39 @@
+#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 (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))))
+
+(module+ test
+  (require rackunit syntax/datum)
+  (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 '(~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))

beautiful-racket-lib/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)

beautiful-racket-lib/br/define.rkt

@@ -0,0 +1,122 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse racket/syntax syntax/datum syntax/strip-context))
+(provide (all-defined-out))
+
+
+(define-syntax-rule (br:debug-define (syntax (id pat-arg ... . rest-arg)) body-exp)
+  (br:define #'(id pat-arg ... . rest-arg)
+             #`(begin
+                 (for-each displayln
+                           (list
+                            (format "input pattern = #'~a" '#,'(id pat-arg ... . rest-arg))
+                            (format "output pattern = #'~a" (cadr '#,'body-exp))
+                            (format "invoked as = ~a" (syntax->datum #'(id pat-arg ... . rest-arg)))
+                            (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 (br:define stx)
+  (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 (id pat-arg ... . rest-arg)) body ...) ; (define #'(foo arg) #'(+ arg arg))
+     #'(define-syntax id (λ (stx)
+                           (define result
+                             (syntax-case stx ()
+                               [(_ pat-arg ... . rest-arg) body ...]))
+                           (if (not (syntax? result))
+                               (datum->syntax stx result)
+                               result)))]
+    
+    [(_ sid:syntaxed-id sid2:syntaxed-id) ; (define #'f1 #'f2)
+     #'(define-syntax sid.name (make-rename-transformer sid2))]
+
+    [(_ sid:syntaxed-id sid2:syntaxed-thing) ; (define #'f1 #'42)
+     #'(define-syntax sid.name (λ (stx) 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)
+  (br:define #'fortytwo #'42)
+  (check-equal? (plus 42) +)
+  (check-equal? plusser +)
+  (check-equal? (plusser 42) +)
+  (check-equal? (times 10) 100)
+  (check-equal? (timeser 12) 144)
+  (check-equal? (let ()
+                  (br:define #'(foo x)
+                             (with-syntax ([zam +])
+                               #'(zam x x))) (foo 42)) 84) 
+  ;; todo: error from define not trapped by check-exn 
+  #;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*)))
+  (check-equal? fortytwo 42))
+
+
+;; todo: support `else` case
+(define-syntax (br:define-cases stx)
+  (syntax-parse stx
+    #:literals (syntax)
+    ; (define-cases #'foo [#'(_ arg) #'(+ arg arg)] [#'(_ 42 bar) #'42] ...)
+    [(_ (syntax top-id) [(syntax (_ pat-arg ... . rest-arg)) body ...] ...) 
+     #'(define-syntax top-id (λ (stx)
+                               (define result
+                                 (syntax-case stx ()
+                                   [(_ pat-arg ... . rest-arg) body ...] ...))
+                               (if (not (syntax? result))
+                                   (datum->syntax stx result)
+                                   result)))]
+    
+    [(_ top-id [(_ pat-arg ... . rest-arg) body ...] ...)
+     #'(define top-id
+         (case-lambda
+           [(pat-arg ... . rest-arg) body ...] ...))]))
+
+(module+ test
+  (br:define-cases #'op
+    [#'(_ "+") #''got-plus]
+    [#'(_ arg) #''got-something-else])
+
+  (check-equal? (op "+") 'got-plus)
+  (check-equal? (op 42) 'got-something-else)
+  
+  (br:define-cases f
+    [(_ arg) (add1 arg)]
+    [(_ arg1 arg2) (+ arg1 arg2)])
+
+  (check-equal? (f 42) 43)
+  (check-equal? (f 42 5) 47))

beautiful-racket-lib/br/eopl.rkt

@@ -0,0 +1,96 @@
+#lang br
+(require rackunit 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))]))
+
+
+
+(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/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)

beautiful-racket-lib/br/main.rkt

@@ -0,0 +1,25 @@
+#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/conditional
+         (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 br/conditional)
+         (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
+
+(define (remove-blank-lines strs)
+  (filter (λ(str) (regexp-match #px"\\S" str)) strs))
+
+(provide remove-blank-lines)
+
+
+(module reader syntax/module-reader
+  #:language 'br)

beautiful-racket-lib/br/read-functions.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+(require (for-syntax racket/base) syntax/strip-context)
+(provide define-read-functions)
+
+;; `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-syntax (define-read-functions use-site-stx)
+  (syntax-case use-site-stx ()
+    [(_ (PATH PORT) BODY ...)
+     (with-syntax ([READ (datum->syntax use-site-stx 'read)]
+                   [READ-SYNTAX (datum->syntax use-site-stx 'read-syntax)])
+       #'(begin           
+           (provide READ READ-SYNTAX)
+           (define (use-site-read-function PATH PORT)
+             BODY ...) ; don't care whether this produces datum or syntax
+           
+           (define (READ-SYNTAX path port)
+             ;; because `read-syntax` must produce syntax
+             ;; coerce a datum result to syntax if needed (à la `with-syntax`)
+             (define result-syntax (let ([output (use-site-read-function path port)])
+                                     (if (syntax? output)
+                                         output 
+                                         (datum->syntax #f output))))
+             ;; because `read-syntax` must produce syntax without context
+             ;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
+             ;; "a `read-syntax` function should return a syntax object with no lexical context"
+             (strip-context result-syntax)) 
+           
+           (define (READ port)
+             ; because `read` must produce a datum
+             (let ([output (use-site-read-function #f port)])
+               (if (syntax? output)
+                   (syntax->datum output)
+                   output)))))]))

beautiful-racket-lib/br/syntax.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+(require (for-syntax racket/base syntax/parse) syntax/strip-context)
+(provide (all-defined-out) (all-from-out syntax/strip-context))
+
+
+(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)
+  ;; 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-syntax syntax-variable (make-rename-transformer #'format-id))

beautiful-racket-lib/br/test.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(provide message)
+(define message "You installed beautiful-racket correctly.")
+(module+ main
+  (displayln message))

beautiful-racket-lib/info.rkt

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