mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

tidying

Browse Source
pull/10/head
Matthew Butterick 8 years ago
parent 18081e6d6e
commit 5b894d8ae8
14 changed files with 74 additions and 488 deletions
Show Stats Download Patch File Download Diff File

4
beautiful-racket-demo/basic-demo-2/sample-math.rkt
Unescape Escape View File

@ -5,5 +5,5 @@
40 print 1 / 4 = .25 40 print 1 / 4 = .25
50 print 2 ^ 3 = 8 50 print 2 ^ 3 = 8
60 print 9 ^ 0.5 = 3 60 print 9 ^ 0.5 = 3
70 print 6 % 2 = 0 70 print 6 mod 2 = 0
80 print 5 % 2 = 1 80 print 5 mod 2 = 1

46
beautiful-racket-demo/bf-demo/atsign-sexp.rkt
Unescape Escape View File

@ -1,26 +1,26 @@
#lang s-exp "bf-expander.rkt" #lang s-exp "expander.rkt"
(bf-program (bf-program
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(loop (bf-loop
"[" "["
(op ">") (bf-op ">")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "+") (bf-op "+")
(op "<") (bf-op "<")
(op "-") (bf-op "-")
"]") "]")
(op ">") (bf-op ">")
(op ".")) (bf-op "."))

21
beautiful-racket-lib/br/exception.rkt
Unescape Escape View File

@ -1,21 +0,0 @@
#lang racket/base
(require (for-syntax racket/base br/syntax) br/define racket/match)
(provide (all-defined-out))
(define-macro (define-exn EXN-ID BASE-EXN)
(with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
#'(begin
(define-struct (EXN-ID BASE-EXN)
(a-srcloc) #:transparent
#:property prop:exn:srclocs
(lambda (a-struct)
(match a-struct
[(struct EXN-ID
(msg marks a-srcloc))
(list a-srcloc)])))
(define RAISE-EXN-ID
(case-lambda
[(srcloc)
(raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks) srcloc))]
[()
(raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))])))))

73
beautiful-racket-lib/br/experimental/eopl.rkt
Unescape Escape View File

@ -1,73 +0,0 @@
#lang br
(require racket/struct (for-syntax br/datum))
(provide define-datatype cases occurs-free?)
(define-macro (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-syntax (cases stx)
(syntax-case stx (else)
[(_ _base-type INPUT-VAR
[SUBTYPE (POSITIONAL-VAR ...) . _body] ...
[else . _else-body])
(inject-syntax ([#'(_subtype? ...) (suffix-id #'(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-macro-cases cases
[(_ BASE-TYPE INPUT-VAR
[SUBTYPE (POSITIONAL-VAR ...) . BODY] ...
[else . ELSE-BODY])
(with-syntax ([(SUBTYPE? ...) (suffix-id #'(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))]))
(module+ test
(require rackunit)
(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)))))))

26
beautiful-racket-lib/br/experimental/load.rkt
Unescape Escape View File

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

127
beautiful-racket-lib/br/experimental/scope.rkt
Unescape Escape View File

@ -1,127 +0,0 @@
#lang racket/base
(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
(provide (all-defined-out))
(define (->syntax x)
(if (syntax? x) x (datum->syntax #f x)))
(define (context stx)
(hash-ref (syntax-debug-info stx) 'context))
(define-syntax-rule (scopes stx)
(format "~a = ~a" 'stx
(cons (syntax->datum stx)
(for/list ([scope (in-list (context stx))])
scope))))
(define (syntax-find stx stx-or-datum)
(unless (syntax? stx)
(raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
(define datum
(cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
[(symbol? stx-or-datum) stx-or-datum]
[else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
(let/ec exit
(let loop ([so stx])
(cond
[(eq? (syntax->datum so) datum) (exit so)]
[(syntax->list so) => (curry map loop)]))))
(define-syntax (define-scope stx)
(syntax-case stx ()
[(_ id)
#'(define-scope id ())]
[(_ id scope-ids)
(with-syntax ([id-sis (suffix-id #'id "-sis")]
[add-id (prefix-id "add-" #'id)]
[flip-id (prefix-id "flip-" #'id)]
[id-binding-form (suffix-id #'id "-binding-form")]
[define-id (prefix-id "define-" #'id)]
[with-id-identifiers (infix-id "with-" #'id "-identifiers")]
[let-id-syntax (infix-id "let-" #'id "-syntax")]
[with-id-binding-form (infix-id "with-" #'id "-binding-form")]
[remove-id (prefix-id "remove-" #'id)]
[id? (suffix-id #'id "?")]
[id* (suffix-id #'id "*")]
[(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
#'(begin
(define id-sis
(let ([sis-in (list scope-id-sis ...)])
(if (pair? sis-in)
(apply append sis-in)
(list
(let ([si (make-syntax-introducer #t)])
(list (procedure-rename (curryr si 'add) 'add-id)
(procedure-rename (curryr si 'flip) 'flip-id)
(procedure-rename (curryr si 'remove) 'remove-id)))))))
(define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
(define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
(define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
(define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
(define (id-binding-form x) (syntax-local-introduce (id x)))
(define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
(define (id? x)
(and
(member (car (context (add-id (datum->syntax #f '_))))
(context (->syntax x)))
#t))
(define-syntax-rule (with-id-identifiers (name (... ...)) . body)
(with-syntax ([name (id* 'name)] (... ...)) . body))
(define-syntax-rule (with-id-binding-form (name (... ...)) . body)
(with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
(define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
(let-syntax ([pat (id* val)] (... ...)) . body))))]))
(define (scopes-equal? stxl stxr)
;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
(bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
(module+ test
(require rackunit)
(define-scope red)
(define stx (datum->syntax #f 'x))
(define red-stx (add-red stx))
(define double-red-stx (add-red (add-red stx)))
(check-false (red? stx))
(check-true (red? red-stx))
(check-true (red? double-red-stx))
(check-false (scopes-equal? stx red-stx))
(check-true (scopes-equal? red-stx double-red-stx))
(check-false (scopes-equal? red-stx (remove-red double-red-stx)))
(define-scope blue) ; scope addition is commutative
(define blue-stx (blue stx))
(check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
(check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
(define-scope green) ; replace scopes at outer layer
(check-true (scopes-equal? (green red-stx) (green blue-stx)))
;; replace scopes everywhere
(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
(car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
;; todo: test flipping
(define-scope purple (red blue))
(check-true (purple? (add-purple stx)))
(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
(define-syntax (with-scopes stx)
(syntax-case stx (syntax)
[(_ (scope-id) (syntax expr))
(with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
#'(add-scope-id expr))]))

37
beautiful-racket-lib/br/experimental/stxparam.rkt
Unescape Escape View File

@ -1,37 +0,0 @@
#lang racket/base
(require (for-syntax racket/base) racket/stxparam racket/splicing)
(provide splicing-syntax-parameterize
define-syntax-parameters
define-language-variables
define-language-variable
inject-language-variables
(rename-out [br:define-syntax-parameter define-syntax-parameter]))
(define-syntax (br:define-syntax-parameter stx)
(syntax-case stx ()
[(_ ID STX) #'(define-syntax-parameter ID STX)]
[(_ [ID VAL]) #'(define-syntax-parameter ID (λ (stx) #'VAL))]
[(_ ID) #'(define-syntax-parameter ID
(λ (stx) (raise-syntax-error (syntax-e stx) "parameter not set")))]))
(define-syntax-rule (define-syntax-parameters ID ...)
(begin (br:define-syntax-parameter ID) ...))
(define-syntax-rule (define-language-variable ID VAL)
(br:define-syntax-parameter [ID VAL]))
(define-syntax-rule (define-language-variables [ID VAL] ...)
(begin (define-language-variable ID VAL) ...))
(define-syntax (inject-language-variables stx)
(syntax-case stx ()
[(_ (VAR-PARAM ...) LANG-CODE ...)
(with-syntax ([(HOLDS-ORIG-PARAM-VALUE ...) (generate-temporaries #'(VAR-PARAM ...))]
[(INTERNAL-NAME ...) (generate-temporaries #'(VAR-PARAM ...))])
;; need to use splicing expressions in a module-begin to compose with requires etc. that might be in lang code
#'(splicing-let ([HOLDS-ORIG-PARAM-VALUE VAR-PARAM] ...)
(splicing-syntax-parameterize
([VAR-PARAM (make-rename-transformer #'INTERNAL-NAME)] ...)
(define INTERNAL-NAME HOLDS-ORIG-PARAM-VALUE) ...
(provide (rename-out [INTERNAL-NAME VAR-PARAM] ...))
LANG-CODE ...)))]))

14
beautiful-racket-lib/br/list.rkt
Unescape Escape View File

@ -1,17 +1,21 @@
#lang racket/base #lang racket/base
(require br/define (for-syntax racket/base)) (require br/define (for-syntax racket/base syntax/parse))
(provide (all-defined-out)) (provide (all-defined-out))
(define-macro (values->list EXPR) (define-macro (values->list EXPR)
#'(call-with-values (λ () EXPR) list)) #'(call-with-values (λ () EXPR) list))
(define-macro (push! ID VAL) (define-syntax (push! stx)
#'(set! ID (cons VAL ID))) (syntax-parse stx
[(_ ID:id VAL)
#'(set! ID (cons VAL ID))]))
(define-macro (pop! ID) (define-syntax (pop! stx)
(syntax-parse stx
[(_ ID:id)
#'(let ([x (car ID)]) #'(let ([x (car ID)])
(set! ID (cdr ID)) (set! ID (cdr ID))
x)) x)]))
(module+ test (module+ test
(require rackunit) (require rackunit)

4
beautiful-racket-lib/br/main.rkt
Unescape Escape View File

@ -1,10 +1,10 @@
#lang racket/base #lang racket/base
(require racket/provide racket/list racket/string racket/format racket/match racket/port racket/function racket/provide (require racket/provide racket/list racket/string racket/format racket/match racket/port racket/function racket/provide
br/define br/syntax br/datum br/debug br/cond br/exception br/list racket/class racket/vector br/reader-utils br/define br/syntax br/datum br/debug br/cond br/list racket/class racket/vector
(for-syntax racket/base racket/syntax br/syntax br/debug br/define br/datum)) (for-syntax racket/base racket/syntax br/syntax br/debug br/define br/datum))
(provide (all-from-out racket/base) (provide (all-from-out racket/base)
(all-from-out racket/list racket/string racket/format racket/match racket/port racket/function racket/provide (all-from-out racket/list racket/string racket/format racket/match racket/port racket/function racket/provide
br/syntax br/datum br/debug br/cond br/exception br/list racket/class racket/vector br/define br/reader-utils) br/syntax br/datum br/debug br/cond br/list racket/class racket/vector br/define)
(for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug br/datum)) (for-syntax (all-from-out racket/base racket/syntax br/syntax br/debug br/datum))
(for-syntax caller-stx with-shared-id)) ; from br/define (for-syntax caller-stx with-shared-id)) ; from br/define

21
beautiful-racket-lib/br/private/generate-literals.rkt
Unescape Escape View File

@ -1,20 +1,17 @@
#lang racket/base #lang racket/base
(require racket/list "syntax-flatten.rkt") (require "syntax-flatten.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(define (upcased-and-capitalized? sym) ;; generate literals for any symbols that are not ... or _ and not IN_CAPS
(define str (symbol->string sym))
(and (equal? (string-upcase str) str)
(let ([first-letter (substring str 0 1)])
(or (and (string->number first-letter) #t) ; leading digit OK
(not (equal? (string-downcase first-letter) first-letter))))))
(define (generate-literals pats) (define (generate-literals pats)
;; generate literals for any symbols that are not ... or _
(define pattern-arg-prefixer "_")
(for*/list ([pat-arg (in-list (syntax-flatten pats))] (for*/list ([pat-arg (in-list (syntax-flatten pats))]
[pat-datum (in-value (syntax->datum pat-arg))] [pat-datum (in-value (syntax->datum pat-arg))]
#:when (and (symbol? pat-datum) #:when (and (symbol? pat-datum)
(not (member pat-datum '(... _))) ; exempted from literality (not (memq pat-datum '(... _))) ; exempted from literality
(not (upcased-and-capitalized? pat-datum)))) (let ([pat-str (symbol->string pat-datum)])
(not (equal? (string-upcase pat-str) pat-str)))))
pat-arg)) pat-arg))
(module+ test
(require rackunit)
(check-equal? (map syntax->datum (generate-literals #'(foo 42 BAR _ bar 3bar))) '(foo bar 3bar)))

12
beautiful-racket-lib/br/private/syntax-flatten.rkt
Unescape Escape View File

@ -3,10 +3,14 @@
(provide (all-defined-out)) (provide (all-defined-out))
(define (syntax-flatten stx) (define (syntax-flatten stx)
(flatten
(let loop ([stx stx])
(let* ([stx-unwrapped (syntax-e stx)] (let* ([stx-unwrapped (syntax-e stx)]
[maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))]) [maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))])
(if maybe-pair (if maybe-pair
(map loop maybe-pair) (append-map syntax-flatten maybe-pair)
stx))))) (list stx))))
(module+ test
(require rackunit)
(check-equal? (map syntax->datum (syntax-flatten #'(let ([x 42])
(* x y)))) '(let x 42 * x y))
(check-equal? (map syntax->datum (syntax-flatten #'let)) '(let)))

19
beautiful-racket-lib/br/quicklang.rkt
Unescape Escape View File

@ -5,26 +5,9 @@
(for-syntax (all-from-out sugar/debug))) (for-syntax (all-from-out sugar/debug)))
(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)])
(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
kw-pairs)
(cddr exprs))
(values kw-pairs exprs))))
(define reserved-keywords '(provide))
(define (reserved? kw-pair) (memq (car kw-pair) reserved-keywords))
(define-values (reserved-kwpairs other-kwpairs) (partition reserved? kw-pairs))
(with-pattern ([((KW . VAL) ...) other-kwpairs]
[(PROVIDED-ID ...) (or (assq 'provide reserved-kwpairs) null)])
#`(#%module-begin #`(#%module-begin
(provide PROVIDED-ID ...)
(provide (rename-out [VAL KW]) ...)
(provide #%top #%app #%datum #%top-interaction) (provide #%top #%app #%datum #%top-interaction)
. #,(datum->syntax #'EXPRS other-exprs #'EXPRS)))) . EXPRS))
(module reader syntax/module-reader (module reader syntax/module-reader
#:language 'br/quicklang #:language 'br/quicklang

44
beautiful-racket-lib/br/reader-utils.rkt
Unescape Escape View File

@ -1,44 +0,0 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
(provide define-read-and-read-syntax test-reader)
(define (test-reader read-syntax-proc str)
(syntax->datum (read-syntax-proc #f (open-input-string str))))
;; `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-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
(let ([internal-prefix (gensym)])
(with-syntax ([READ (datum->syntax caller-stx 'read)]
[READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
[INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
[INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
#'(begin
(provide (rename-out [INTERNAL-READ READ]
[INTERNAL-READ-SYNTAX READ-SYNTAX]))
(define (calling-site-function PATH PORT)
BODY ...) ; don't care whether this produces datum or syntax
(define INTERNAL-READ-SYNTAX
(procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
;; because `read-syntax` must produce syntax
;; coerce a datum result to syntax if needed (à la `with-syntax`)
(define result-syntax (let ([output (calling-site-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)) 'READ-SYNTAX))
(define INTERNAL-READ
(procedure-rename (λ (port)
; because `read` must produce a datum
(let ([output (calling-site-function #f port)])
(if (syntax? output)
(syntax->datum output)
output))) 'READ))))))

92
beautiful-racket-lib/br/syntax.rkt
Unescape Escape View File

@ -28,18 +28,14 @@
(define-macro-cases case-pattern (define-macro-cases case-pattern
[(_ STX-ARG [(_ STX-ARG
[PAT . BODY] [PAT . BODY] ...
...
[else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))]) [else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))])
#'(syntax-case STX-ARG (LITERAL ...) #'(syntax-case STX-ARG (LITERAL ...)
[PAT . BODY] [PAT . BODY] ...
...
[else . ELSEBODY]))] [else . ELSEBODY]))]
[(_ STX-ARG [(_ STX-ARG
PAT+BODY PAT+BODY ...) #'(case-pattern STX-ARG
...) #'(case-pattern STX-ARG PAT+BODY ...
PAT+BODY
...
[else (raise-syntax-error 'case-pattern [else (raise-syntax-error 'case-pattern
(format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])]) (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])])
@ -53,44 +49,12 @@
(format "unable to match pattern ~a" 'PAT0) STX0)]))]) (format "unable to match pattern ~a" 'PAT0) STX0)]))])
(define (check-syntax-list-argument caller-name arg)
(cond
[(and (syntax? arg) (syntax->list arg))]
[(list? arg) arg]
[else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
(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-macro (reformat-id FMT ID0 ID ...)
#'(format-id ID0 FMT ID0 ID ...))
(define-macro (format-string FMT ID0 ID ...) (define-macro (format-string FMT ID0 ID ...)
#'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...))) #'(datum->syntax ID0 (format FMT (syntax->datum ID0) (syntax->datum ID) ...)))
#|
(define (format-string FMT ID0 . IDS)
(datum->syntax ID0 (apply format FMT (syntax->datum ID0) (map syntax->datum IDS))))
|#
(define (->unsyntax x) (if (syntax? x) (syntax->datum x) x))
(define (->unsyntax x) (define (*fix-base loc-arg prefixes base-or-bases suffixes)
(if (syntax? x) (syntax->datum x) x))
(define (fix-base loc-arg prefixes base-or-bases suffixes)
(define single-mode? (and (not (list? base-or-bases)) (not (syntax->list base-or-bases)))) (define single-mode? (and (not (list? base-or-bases)) (not (syntax->list base-or-bases))))
(define bases (if single-mode? (list base-or-bases) (or (syntax->list base-or-bases) base-or-bases))) (define bases (if single-mode? (list base-or-bases) (or (syntax->list base-or-bases) base-or-bases)))
(define (stx-join stxs) (apply string-append (map (compose1 ~a ->unsyntax) stxs))) (define (stx-join stxs) (apply string-append (map (compose1 ~a ->unsyntax) stxs)))
@ -102,17 +66,17 @@
(define (prefix-id #:source [loc-arg #f] . args) (define (prefix-id #:source [loc-arg #f] . args)
((match-lambda ((match-lambda
[(list prefixes ... base-or-bases) [(list prefixes ... base-or-bases)
(fix-base loc-arg prefixes base-or-bases empty)]) args)) (*fix-base loc-arg prefixes base-or-bases empty)]) args))
(define (infix-id #:source [loc-arg #f] . args) (define (infix-id #:source [loc-arg #f] . args)
((match-lambda ((match-lambda
[(list prefix base-or-bases suffixes ...) [(list prefix base-or-bases suffixes ...)
(fix-base loc-arg (list prefix) base-or-bases suffixes)]) args)) (*fix-base loc-arg (list prefix) base-or-bases suffixes)]) args))
(define (suffix-id #:source [loc-arg #f] . args) (define (suffix-id #:source [loc-arg #f] . args)
((match-lambda ((match-lambda
[(list base-or-bases suffixes ...) [(list base-or-bases suffixes ...)
(fix-base loc-arg empty base-or-bases suffixes)]) args)) (*fix-base loc-arg empty base-or-bases suffixes)]) args))
(module+ test (module+ test
(define-check (check-stx-equal? stx1 stx2) (define-check (check-stx-equal? stx1 stx2)
@ -124,44 +88,6 @@
(for-each check-stx-equal? (suffix-id #'(this that) "@") (list #'this@ #'that@))) (for-each check-stx-equal? (suffix-id #'(this that) "@") (list #'this@ #'that@)))
(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] ...)])
#|
(define (syntax-property* . args)
((match-lambda*
[(list x) x]
[(list stx (list prop val others ...)) ; write one
(apply syntax-property stx prop val others)]
[(list stx (list prop val others ...) args ...) ; write multiple
#'(apply syntax-property* (apply syntax-property stx prop val others) args)]
[(list stx prop) ; read one
(syntax-property stx prop)]
[(list stx prop0 props ...) ; read multiple
(map (λ (prop) (syntax-property stx prop)) (cons prop0 props))]
[else 'huh]) args))
|#
(define (filter-stx-prop prop stxs)
(filter (λ (stx) (syntax-property stx prop)) stxs))
(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)))
(define (syntax-srcloc stx) (define (syntax-srcloc stx)
(srcloc (syntax-source stx) (srcloc (syntax-source stx)
(syntax-line stx) (syntax-line stx)

Write Preview
Loading…
Cancel
Save