diff --git a/.travis.yml b/.travis.yml index d5930f0..43105e6 100644 --- a/.travis.yml +++ b/.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 diff --git a/README.md b/README.md index f599958..610e14e 100644 --- a/README.md +++ b/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 diff --git a/beautiful-racket-lib/br/conditional.rkt b/beautiful-racket-lib/br/conditional.rkt new file mode 100644 index 0000000..c28b561 --- /dev/null +++ b/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)))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/datum.rkt b/beautiful-racket-lib/br/datum.rkt new file mode 100644 index 0000000..192fd57 --- /dev/null +++ b/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 ) ...) + #'(format-datum (datum ) ...)] + [(_ (datum datum-template) ...) + (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 ...)))))]))) + +(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)) diff --git a/beautiful-racket-lib/br/debug.rkt b/beautiful-racket-lib/br/debug.rkt new file mode 100644 index 0000000..6a46b05 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt new file mode 100644 index 0000000..1eaec3d --- /dev/null +++ b/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 ) + #'(apply + (list ))) + (foo 1 2 3)) 6) + (check-equal? (let () + (br:debug-define #'(foo ...) #'(apply * (list ...))) + (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)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/eopl.rkt b/beautiful-racket-lib/br/eopl.rkt new file mode 100644 index 0000000..d7c8cc9 --- /dev/null +++ b/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 + ( [ ] ...) ...) + #'(begin + (struct () #:transparent #:mutable) + (struct ( ...) #:transparent #:mutable + #:guard (λ( ... name) + (unless ( ) + (error name (format "arg ~a is not ~a" '))) ... + (values ...))) ...)) + + +(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) + [(_ + [ ( ...) ...] ... + [else ...]) + (inject-syntax ([#'( ...) (map-syntax (λ(s) (format-datum '~a? s)) #'( ...))]) + #'(cond + [( ) (match-let ([(list ...) (struct->list )]) + ...)] ... + [else ...]))] + [(_ + ...) + #'(cases + ... + [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)))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/load.rkt b/beautiful-racket-lib/br/load.rkt new file mode 100644 index 0000000..c1e39fc --- /dev/null +++ b/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) \ No newline at end of file diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt new file mode 100644 index 0000000..9ab9ab9 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/beautiful-racket-lib/br/read-functions.rkt b/beautiful-racket-lib/br/read-functions.rkt new file mode 100644 index 0000000..b9fa490 --- /dev/null +++ b/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)))))])) diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt new file mode 100644 index 0000000..b94d993 --- /dev/null +++ b/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 () + [(_ ...) + #'(map (if (and (syntax? ) (list? (syntax-e ))) + (syntax->list ) + ) ...)])) + + +#;(define-syntax syntax-variable (make-rename-transformer #'format-id)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/test.rkt b/beautiful-racket-lib/br/test.rkt new file mode 100644 index 0000000..2e4ecd2 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/beautiful-racket-lib/info.rkt b/beautiful-racket-lib/info.rkt new file mode 100644 index 0000000..372d8ed --- /dev/null +++ b/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")) \ No newline at end of file diff --git a/br-bf/bf-hash-sexp.rkt b/beautiful-racket/br-bf/bf-hash-sexp.rkt similarity index 100% rename from br-bf/bf-hash-sexp.rkt rename to beautiful-racket/br-bf/bf-hash-sexp.rkt diff --git a/br-bf/bf-hash.rkt b/beautiful-racket/br-bf/bf-hash.rkt similarity index 100% rename from br-bf/bf-hash.rkt rename to beautiful-racket/br-bf/bf-hash.rkt diff --git a/br-bf/hello-world.rkt b/beautiful-racket/br-bf/hello-world.rkt similarity index 100% rename from br-bf/hello-world.rkt rename to beautiful-racket/br-bf/hello-world.rkt diff --git a/br-bf/info.rkt b/beautiful-racket/br-bf/info.rkt similarity index 100% rename from br-bf/info.rkt rename to beautiful-racket/br-bf/info.rkt diff --git a/br-bf/main.rkt b/beautiful-racket/br-bf/main.rkt similarity index 100% rename from br-bf/main.rkt rename to beautiful-racket/br-bf/main.rkt diff --git a/br-bf/parser.rkt b/beautiful-racket/br-bf/parser.rkt similarity index 100% rename from br-bf/parser.rkt rename to beautiful-racket/br-bf/parser.rkt diff --git a/br-bf/reader-proc-test.rkt b/beautiful-racket/br-bf/reader-proc-test.rkt similarity index 100% rename from br-bf/reader-proc-test.rkt rename to beautiful-racket/br-bf/reader-proc-test.rkt diff --git a/br-bf/tokenizer.rkt b/beautiful-racket/br-bf/tokenizer.rkt similarity index 100% rename from br-bf/tokenizer.rkt rename to beautiful-racket/br-bf/tokenizer.rkt diff --git a/info.rkt b/beautiful-racket/info.rkt similarity index 100% rename from info.rkt rename to beautiful-racket/info.rkt