working files

dev-elider-3
Matthew Butterick 9 years ago
parent 82fd902915
commit 892d81bfb5

@ -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`

@ -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))

@ -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)

@ -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) #'*))))

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

@ -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)
|#

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

@ -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))))

@ -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)))))

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

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

@ -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))))

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

@ -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))))

@ -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 *

@ -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))

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

@ -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)

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

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

@ -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)

@ -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)

@ -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 +)}))

@ -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))

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