suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactory

Browse Source
This commit is contained in:
Matthew Butterick 2016-08-14 23:01:19 -04:00
parent 4847adf7e9
commit f02e605a9c
11 changed files with 135 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
beautiful-racket-lib/br/define.rkt
View File

@ -3,11 +3,8 @@
racket/function
(for-syntax racket/base
syntax/parse
br/syntax
racket/syntax
syntax/datum
syntax/define
racket/string))
br/private/syntax-flatten
syntax/define))
(provide (all-defined-out)
(for-syntax with-shared-id))
@ -26,18 +23,18 @@
(begin-for-syntax
(define (upcased? str)
(equal? (string-upcase str) str))
(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 _ or _underscore-prefixed
;; 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 (string-prefix? (symbol->string pat-datum) pattern-arg-prefixer))
(not (upcased? (symbol->string pat-datum)))))
(not (upcased-and-capitalized? (symbol->string pat-datum)))))
pat-arg)))
(begin-for-syntax
@ -94,11 +91,11 @@
(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)))
(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 ...)))
(debug-define-macro (foo X ...) #'(apply * (list X ...)))
(foo 10 11 12)) 1320)))
@ -228,7 +225,7 @@
(zam 'this 'that 42)
(check-equal? dirty-zam 'got-dirty-zam)
(define-macro (add _x) #'(+ _x _x))
(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)
@ -240,7 +237,7 @@
(define (foo-func) 'got-foo-func)
(define-macro-cases op
[(_ "+") #''got-plus]
[(_ _ARG) #''got-something-else]
[(_ ARG) #''got-something-else]
[(_) #'(foo-func)]
[_ #'foo-val])
@ -250,7 +247,7 @@
(check-equal? op 'got-foo-val)
(define-macro-cases elseop
[(_ _arg) #''got-arg]
[(_ ARG) #''got-arg]
[else #''got-else])
(check-equal? (elseop "+") 'got-arg)

3
beautiful-racket-lib/br/experimental/eopl.rkt
View File

@ -2,7 +2,7 @@
(require racket/struct (for-syntax br/datum))
(provide define-datatype cases occurs-free?)
(define-macro (define-datatype BASE-TYPE _base-type-predicate?
(define-macro (define-datatype BASE-TYPE BASE-TYPE-PREDICATE?
(SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...)
#'(begin
(struct BASE-TYPE () #:transparent #:mutable)
@ -35,6 +35,7 @@
SUBTYPE-CASE ...
[else (void)])]))
(define-macro-cases cases
[(_ BASE-TYPE INPUT-VAR
[SUBTYPE (POSITIONAL-VAR ...) . BODY] ...

12
beautiful-racket-lib/br/private/syntax-flatten.rkt Normal file
View File

@ -0,0 +1,12 @@
#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)))))

92
beautiful-racket-lib/br/private/to-string.rkt
View File

@ -1,92 +0,0 @@
#lang racket/base
(require racket/contract/base
syntax/stx)
(require racket/list)
(define (syntax->string c)
(let* ([s (open-output-string)]
[l (syntax->list c)]
[init-col (or (syntax-column (first l)) 0)]
[col init-col]
[line (or (syntax-line (first l)) 0)])
(define (advance c init-line!)
(let ([c (syntax-column c)]
[l (syntax-line c)])
(when (and l (l . > . line))
(for-each (λ (_) (newline)) (range (- l line)))
(set! line l)
(init-line!))
(when c
(display (make-string (max 0 (- c col)) #\space))
(set! col c))))
(parameterize ([current-output-port s]
[read-case-sensitive #t])
(define (loop init-line!)
(lambda (c)
(cond
[(eq? 'code:blank (syntax-e c))
(advance c init-line!)]
[(eq? '_ (syntax-e c)) (void)]
[(eq? '... (syntax-e c))
(void)]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:comment))
(advance c init-line!)
(printf "; ")
(display (syntax-e (cadr (syntax->list c))))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'code:contract))
(advance c init-line!)
(printf "; ")
(let* ([l (cdr (syntax->list c))]
[s-col (or (syntax-column (first l)) col)])
(set! col s-col)
(for-each (loop (lambda ()
(set! col s-col)
(printf "; ")))
l))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'quote))
(advance c init-line!)
(printf "'")
(let ([i (cadr (syntax->list c))])
(set! col (or (syntax-column i) col))
((loop init-line!) i))]
[(pair? (syntax-e c))
(advance c init-line!)
(define c-paren-shape (syntax-property c 'paren-shape))
(printf (format "~a" (or c-paren-shape #\()))
(set! col (+ col 1))
(map (loop init-line!) (syntax->list c))
(printf (case c-paren-shape
[(#\[) "]"]
[(#\{) "}"]
[else ")"]))
(set! col (+ col 1))]
[(vector? (syntax-e c))
(advance c init-line!)
(printf "#(")
(set! col (+ col 2))
(map (loop init-line!) (vector->list (syntax-e c)))
(printf ")")
(set! col (+ col 1))]
[else
(advance c init-line!)
(let ([s (format "~s" (syntax-e c))])
(set! col (+ col (string-length s)))
(display s))])))
(for-each (loop (lambda () (set! col init-col))) l))
(get-output-string s)))
(provide/contract [syntax->string (-> (and/c syntax? stx-list?)
string?)])
(module+ test
(require rackunit)
(check-equal? (syntax->string
#'((define (f x)
[+ x x])
(define (g x)
(* x x)))) "(define (f x)\n [+ x x])\n\n(define (g x)\n (* x x))"))

6
beautiful-racket-lib/br/quicklang.rkt
View File

@ -3,10 +3,10 @@
(provide (except-out (all-from-out br) #%module-begin)
(rename-out [quicklang-mb #%module-begin]))
(define-macro (quicklang-mb . exprs)
(define-macro (quicklang-mb . EXPRS)
(define-values
(kw-pairs other-exprs)
(let loop ([kw-pairs null][exprs (syntax->list #'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
@ -22,7 +22,7 @@
(provide PROVIDED-ID ...)
(provide (rename-out [VAL KW]) ...)
(provide #%top #%app #%datum #%top-interaction)
. #,(datum->syntax #'exprs other-exprs #'exprs))))
. #,(datum->syntax #'EXPRS other-exprs #'EXPRS))))
(module reader syntax/module-reader

212
beautiful-racket-lib/br/syntax.rkt
View File

@ -1,45 +1,29 @@
#lang racket/base
(require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context)
syntax/strip-context racket/function racket/list racket/syntax "private/to-string.rkt")
(provide (all-defined-out) (all-from-out syntax/strip-context)
(rename-out [strip-context strip-identifier-bindings]))
(require (for-syntax racket/base racket/syntax)
racket/list
racket/syntax
br/define
br/private/syntax-flatten)
(provide (all-defined-out)
syntax-flatten)
(module+ test
(require rackunit))
(define-syntax (syntax-match stx)
(syntax-case stx (syntax)
[(_ stx-arg [(syntax pattern) body ...] ...)
#'(syntax-case stx-arg ()
[pattern body ...] ...)]))
(define-syntax (inject-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 ...)
#'(inject-syntax ([sid sid-stx] ...) body ...)]
[(_ ([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-macro (syntax-match STX-ARG [(syntax PATTERN) BODY ...] ...)
#'(syntax-case STX-ARG ()
[PATTERN BODY ...] ...))
(define-syntax (inject-syntax* stx)
(syntax-case stx ()
[(_ () . body) #'(begin . body)]
[(_ (stx-expr0 stx-expr ...) . body)
#'(inject-syntax (stx-expr0)
(inject-syntax* (stx-expr ...) . body))]))
(define-syntax with-pattern (make-rename-transformer #'inject-syntax*))
(define-syntax let-syntax-pattern (make-rename-transformer #'inject-syntax*))
(define-syntax let*-syntax-pattern (make-rename-transformer #'inject-syntax*))
(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
(define-syntax add-syntax (make-rename-transformer #'inject-syntax))
(define-macro-cases with-pattern
[(_ () . 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-syntax-rule (test-macro mac-expr)
(syntax->datum (expand-once #'mac-expr)))
(define (check-syntax-list-argument caller-name arg)
(cond
@ -48,118 +32,84 @@
[else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
(define-syntax-rule (syntax-case-partition _stx-list _literals . _matchers)
(partition (λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item _literals
. _matchers))) (check-syntax-list-argument 'syntax-case-partition _stx-list)))
(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-syntax-rule (syntax-case-filter _stx-list _literals . _matchers)
(filter (λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item _literals
. _matchers))) (check-syntax-list-argument 'syntax-case-filter _stx-list)))
(define-macro (reformat-id FMT ID0 ID ...)
#'(format-id ID0 FMT ID0 ID ...))
(define-syntax-rule (syntax-case-map _stx-list _literals . _matchers)
(map (λ(stx-item)
(syntax-case stx-item _literals
. _matchers)) (check-syntax-list-argument 'syntax-case-map _stx-list)))
(define-macro (format-string FMT ID0 ID ...)
#'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
(define-syntax-rule (reformat-id fmt id0 id ...)
(format-id id0 fmt id0 id ...))
(define-syntax-rule (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-syntax-rule (->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-syntax-rule (prefix-id _prefix ... _base-or-bases)
(let* ([bob _base-or-bases]
[got-single? (and (not (list? bob)) (not (syntax->list bob)))]
[bases (if got-single?
(list bob)
bob)]
[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-syntax-rule (infix-id _prefix _base-or-bases _suffix ...)
(let* ([bob _base-or-bases]
[got-single? (and (not (list? bob)) (not (syntax->list bob)))]
[bases (if got-single?
(list bob)
bob)]
[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 (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-syntax-rule (suffix-id _base-or-bases _suffix ...)
(infix-id "" _base-or-bases _suffix ...))
(define-syntax (syntax-property* stx)
(syntax-case stx (quote)
[(_ stx-object 'prop0)
#'(syntax-property stx-object 'prop0)]
[(_ stx-object 'prop0 'prop ...)
#'(cons (syntax-property stx-object 'prop0) (let ([result (syntax-property* stx-object 'prop ...)])
(if (pair? result)
result
(list result))))]
[(_ stx-object ['prop0 val0 . preserved0])
#'(syntax-property stx-object 'prop0 val0 . preserved0)]
[(_ stx-object ['prop0 val0 . preserved0] ['prop val . preserved] ...)
#'(syntax-property* (syntax-property stx-object 'prop0 val0 . preserved0) ['prop val . preserved] ...)]))
(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)))
;; the Søgaard technique
;; http://blog.scheme.dk/2006/05/how-to-write-unhygienic-macro.html
(define-syntax-rule (introduce-id (id ...) . body)
(with-syntax ([id (syntax-local-introduce (syntax-local-get-shadower #'id))] ...)
. body))
(define (syntax-flatten stx)
(flatten
(let loop ([stx stx])
(define maybe-pair (let ([e-stx (syntax-e stx)])
(and (pair? e-stx) (flatten e-stx))))
(if maybe-pair
(map loop maybe-pair)
stx))))
(define-syntax-rule (begin-label LABEL . EXPRS)
(begin
(define LABEL (syntax->string #'EXPRS))
(provide LABEL)
(begin . EXPRS)))
(module+ test
(begin-label
zing
(define (f x)
[+ x x])
(define (g x)
(* x x)))
(check-equal? zing "(define (f x)\n [+ x x])\n\n(define (g x)\n (* x x))")
(check-equal? (f 5) 10)
(check-equal? (g 5) 25))
(check-equal? (syntax-property* x 'foo 'bar 'zam) '(#f #t boni)))

1
beautiful-racket/br/demo/basic/expander.rkt
View File

@ -1,4 +1,5 @@
#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])

4
beautiful-racket/br/demo/hdl-tst/expander.rkt
View File

@ -1,6 +1,6 @@
#lang br
#lang br/quicklang
(require (for-syntax br/syntax racket/string) rackunit racket/file)
(provide #%top-interaction #%module-begin #%datum #%app (all-defined-out))
(provide #%module-begin (all-defined-out))
(define (print-cell val fmt)

32
beautiful-racket/br/demo/hdl/bus.rkt
View File

@ -103,29 +103,29 @@ base bus:
(define-macro-cases define-base-bus
[(_macro-name ID THUNK) #'(_macro-name ID THUNK default-bus-width)]
[(_macro-name ID THUNK _bus-width-in)
[(_ ID THUNK) #'(define-base-bus ID THUNK default-bus-width)]
[(_ ID THUNK BUS-WIDTH-IN)
(with-pattern
([_id-thunk (suffix-id #'ID "-val")]
[_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)])
#`(splicing-let ([_id-thunk THUNK]
[bus-width _bus-width-in])
([ID-THUNK (suffix-id #'ID "-val")]
[BUS-TYPE (or (syntax-property caller-stx 'impersonate) #'bus)])
#`(splicing-let ([ID-THUNK THUNK]
[bus-width BUS-WIDTH-IN])
(define ID
(begin
(unless (<= bus-width max-bus-width)
(raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width))
(impersonate-procedure
(let ([reader (make-bus-reader 'id bus-width)])
(procedure-rename (λ args (apply reader (_id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" 'ID bus-width))))
#f _bus-type #t)))
(procedure-rename (λ args (apply reader (ID-THUNK) args)) (string->symbol (format "~a, a bus of width ~a" 'ID bus-width))))
#f BUS-TYPE #t)))
#,(when (syntax-property caller-stx 'writer)
(with-pattern
([_id-write (suffix-id #'ID "-write")])
#'(define _id-write
(let ([writer (make-bus-writer 'id-write bus-width)])
(λ args
(define result (apply writer (_id-thunk) args))
(set! _id-thunk (λ () result)))))))))])
(define result (apply writer (ID-THUNK) args))
(set! ID-THUNK (λ () result)))))))))])
(module+ test
@ -157,8 +157,8 @@ output bus:
(define-macro (define-output-bus . _args)
(syntax-property #'(define-base-bus . _args) 'impersonate #'output-bus))
(define-macro (define-output-bus . ARGS)
(syntax-property #'(define-base-bus . ARGS) 'impersonate #'output-bus))
(module+ test
(define-output-bus ob (λ () #b0110) 4)
@ -188,10 +188,10 @@ input bus:
(define-macro-cases define-input-bus
[(_macro-name _id)
#'(_macro-name _id default-bus-width)]
[(_macro-name _id _bus-width)
(syntax-property* #'(define-base-bus _id (λ () 0) _bus-width)
[(MACRO-NAME ID)
#'(MACRO-NAME ID default-bus-width)]
[(MACRO-NAME ID BUS-WIDTH)
(syntax-property* #'(define-base-bus ID (λ () 0) BUS-WIDTH)
['impersonate #'input-bus]
['writer #t])])

4
beautiful-racket/br/demo/hdl/expander.rkt
View File

@ -1,6 +1,6 @@
#lang br
#lang br/quicklang
(require "bus.rkt" (for-syntax racket/syntax racket/require-transform br/syntax "bus-properties.rkt"))
(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
(provide #%module-begin (all-defined-out))
(define-macro (chip-program CHIPNAME
(in-spec (IN-BUS IN-WIDTH ...) ...)

7
beautiful-racket/br/demo/hdl/reader.rkt
View File

@ -1,7 +1,6 @@
#lang br
(require br/reader-utils "parser.rkt" "tokenizer.rkt")
(provide read-syntax)
(define (read-syntax source-path input-port)
(strip-context #`(module hdl-mod br/demo/hdl/expander
#,(parse source-path (tokenize input-port)))))
(define-read-and-read-syntax (source-path input-port)
#`(module hdl-mod br/demo/hdl/expander
#,(parse source-path (tokenize input-port))))