From 5b894d8ae803529a569c266a147d1ce0d3e3993c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 19 Feb 2017 21:42:33 -0800 Subject: [PATCH] tidying --- .../basic-demo-2/sample-math.rkt | 4 +- beautiful-racket-demo/bf-demo/atsign-sexp.rkt | 46 +++---- beautiful-racket-lib/br/exception.rkt | 21 --- beautiful-racket-lib/br/experimental/eopl.rkt | 73 ---------- beautiful-racket-lib/br/experimental/load.rkt | 26 ---- .../br/experimental/scope.rkt | 127 ------------------ .../br/experimental/stxparam.rkt | 37 ----- beautiful-racket-lib/br/list.rkt | 18 ++- beautiful-racket-lib/br/main.rkt | 4 +- .../br/private/generate-literals.rkt | 29 ++-- .../br/private/syntax-flatten.rkt | 18 ++- beautiful-racket-lib/br/quicklang.rkt | 23 +--- beautiful-racket-lib/br/reader-utils.rkt | 44 ------ beautiful-racket-lib/br/syntax.rkt | 92 ++----------- 14 files changed, 74 insertions(+), 488 deletions(-) delete mode 100644 beautiful-racket-lib/br/exception.rkt delete mode 100644 beautiful-racket-lib/br/experimental/eopl.rkt delete mode 100644 beautiful-racket-lib/br/experimental/load.rkt delete mode 100644 beautiful-racket-lib/br/experimental/scope.rkt delete mode 100644 beautiful-racket-lib/br/experimental/stxparam.rkt delete mode 100644 beautiful-racket-lib/br/reader-utils.rkt diff --git a/beautiful-racket-demo/basic-demo-2/sample-math.rkt b/beautiful-racket-demo/basic-demo-2/sample-math.rkt index 4c3923f..5a1dc7b 100644 --- a/beautiful-racket-demo/basic-demo-2/sample-math.rkt +++ b/beautiful-racket-demo/basic-demo-2/sample-math.rkt @@ -5,5 +5,5 @@ 40 print 1 / 4 = .25 50 print 2 ^ 3 = 8 60 print 9 ^ 0.5 = 3 -70 print 6 % 2 = 0 -80 print 5 % 2 = 1 +70 print 6 mod 2 = 0 +80 print 5 mod 2 = 1 diff --git a/beautiful-racket-demo/bf-demo/atsign-sexp.rkt b/beautiful-racket-demo/bf-demo/atsign-sexp.rkt index 3c9f767..efa17b2 100644 --- a/beautiful-racket-demo/bf-demo/atsign-sexp.rkt +++ b/beautiful-racket-demo/bf-demo/atsign-sexp.rkt @@ -1,26 +1,26 @@ -#lang s-exp "bf-expander.rkt" +#lang s-exp "expander.rkt" (bf-program - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (loop + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-loop "[" - (op ">") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "+") - (op "<") - (op "-") + (bf-op ">") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "+") + (bf-op "<") + (bf-op "-") "]") - (op ">") - (op ".")) \ No newline at end of file + (bf-op ">") + (bf-op ".")) \ No newline at end of file diff --git a/beautiful-racket-lib/br/exception.rkt b/beautiful-racket-lib/br/exception.rkt deleted file mode 100644 index 7dc9798..0000000 --- a/beautiful-racket-lib/br/exception.rkt +++ /dev/null @@ -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)))]))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/experimental/eopl.rkt b/beautiful-racket-lib/br/experimental/eopl.rkt deleted file mode 100644 index 5f0ac09..0000000 --- a/beautiful-racket-lib/br/experimental/eopl.rkt +++ /dev/null @@ -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))))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/experimental/load.rkt b/beautiful-racket-lib/br/experimental/load.rkt deleted file mode 100644 index c1e39fc..0000000 --- a/beautiful-racket-lib/br/experimental/load.rkt +++ /dev/null @@ -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) \ No newline at end of file diff --git a/beautiful-racket-lib/br/experimental/scope.rkt b/beautiful-racket-lib/br/experimental/scope.rkt deleted file mode 100644 index 6562a7a..0000000 --- a/beautiful-racket-lib/br/experimental/scope.rkt +++ /dev/null @@ -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))])) - diff --git a/beautiful-racket-lib/br/experimental/stxparam.rkt b/beautiful-racket-lib/br/experimental/stxparam.rkt deleted file mode 100644 index c6b1ab7..0000000 --- a/beautiful-racket-lib/br/experimental/stxparam.rkt +++ /dev/null @@ -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 ...)))])) diff --git a/beautiful-racket-lib/br/list.rkt b/beautiful-racket-lib/br/list.rkt index e82d3df..c7cb79a 100644 --- a/beautiful-racket-lib/br/list.rkt +++ b/beautiful-racket-lib/br/list.rkt @@ -1,17 +1,21 @@ #lang racket/base -(require br/define (for-syntax racket/base)) +(require br/define (for-syntax racket/base syntax/parse)) (provide (all-defined-out)) (define-macro (values->list EXPR) #'(call-with-values (λ () EXPR) list)) -(define-macro (push! ID VAL) - #'(set! ID (cons VAL ID))) +(define-syntax (push! stx) + (syntax-parse stx + [(_ ID:id VAL) + #'(set! ID (cons VAL ID))])) -(define-macro (pop! ID) - #'(let ([x (car ID)]) - (set! ID (cdr ID)) - x)) +(define-syntax (pop! stx) + (syntax-parse stx + [(_ ID:id) + #'(let ([x (car ID)]) + (set! ID (cdr ID)) + x)])) (module+ test (require rackunit) diff --git a/beautiful-racket-lib/br/main.rkt b/beautiful-racket-lib/br/main.rkt index 4af43f6..77ea393 100644 --- a/beautiful-racket-lib/br/main.rkt +++ b/beautiful-racket-lib/br/main.rkt @@ -1,10 +1,10 @@ #lang racket/base (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)) (provide (all-from-out racket/base) (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 caller-stx with-shared-id)) ; from br/define diff --git a/beautiful-racket-lib/br/private/generate-literals.rkt b/beautiful-racket-lib/br/private/generate-literals.rkt index a43a42f..f1eb466 100644 --- a/beautiful-racket-lib/br/private/generate-literals.rkt +++ b/beautiful-racket-lib/br/private/generate-literals.rkt @@ -1,20 +1,17 @@ #lang racket/base -(require racket/list "syntax-flatten.rkt") +(require "syntax-flatten.rkt") (provide (all-defined-out)) -(define (upcased-and-capitalized? sym) - (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)))))) +;; generate literals for any symbols that are not ... or _ and not IN_CAPS +(define (generate-literals pats) + (for*/list ([pat-arg (in-list (syntax-flatten pats))] + [pat-datum (in-value (syntax->datum pat-arg))] + #:when (and (symbol? pat-datum) + (not (memq pat-datum '(... _))) ; exempted from literality + (let ([pat-str (symbol->string pat-datum)]) + (not (equal? (string-upcase pat-str) pat-str))))) + pat-arg)) - (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))] - [pat-datum (in-value (syntax->datum pat-arg))] - #:when (and (symbol? pat-datum) - (not (member pat-datum '(... _))) ; exempted from literality - (not (upcased-and-capitalized? pat-datum)))) - pat-arg)) \ No newline at end of file +(module+ test + (require rackunit) + (check-equal? (map syntax->datum (generate-literals #'(foo 42 BAR _ bar 3bar))) '(foo bar 3bar))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/private/syntax-flatten.rkt b/beautiful-racket-lib/br/private/syntax-flatten.rkt index 5e44af0..ad8ea8d 100644 --- a/beautiful-racket-lib/br/private/syntax-flatten.rkt +++ b/beautiful-racket-lib/br/private/syntax-flatten.rkt @@ -3,10 +3,14 @@ (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))))) \ No newline at end of file + (let* ([stx-unwrapped (syntax-e stx)] + [maybe-pair (and (pair? stx-unwrapped) (flatten stx-unwrapped))]) + (if maybe-pair + (append-map syntax-flatten maybe-pair) + (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))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/quicklang.rkt b/beautiful-racket-lib/br/quicklang.rkt index d52b4d5..dc5666d 100644 --- a/beautiful-racket-lib/br/quicklang.rkt +++ b/beautiful-racket-lib/br/quicklang.rkt @@ -5,26 +5,9 @@ (for-syntax (all-from-out sugar/debug))) (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 - (provide PROVIDED-ID ...) - (provide (rename-out [VAL KW]) ...) - (provide #%top #%app #%datum #%top-interaction) - . #,(datum->syntax #'EXPRS other-exprs #'EXPRS)))) - + #`(#%module-begin + (provide #%top #%app #%datum #%top-interaction) + . EXPRS)) (module reader syntax/module-reader #:language 'br/quicklang diff --git a/beautiful-racket-lib/br/reader-utils.rkt b/beautiful-racket-lib/br/reader-utils.rkt deleted file mode 100644 index d3030bb..0000000 --- a/beautiful-racket-lib/br/reader-utils.rkt +++ /dev/null @@ -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)))))) \ No newline at end of file diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 35808b9..41a28c5 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -28,18 +28,14 @@ (define-macro-cases case-pattern [(_ STX-ARG - [PAT . BODY] - ... + [PAT . BODY] ... [else . ELSEBODY]) (with-syntax ([(LITERAL ...) (generate-literals #'(PAT ...))]) #'(syntax-case STX-ARG (LITERAL ...) - [PAT . BODY] - ... + [PAT . BODY] ... [else . ELSEBODY]))] [(_ STX-ARG - PAT+BODY - ...) #'(case-pattern STX-ARG - PAT+BODY - ... + PAT+BODY ...) #'(case-pattern STX-ARG + PAT+BODY ... [else (raise-syntax-error 'case-pattern (format "unable to match pattern for ~v" (syntax->datum STX-ARG)))])]) @@ -53,44 +49,12 @@ (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 ...) #'(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) - (if (syntax? x) (syntax->datum x) x)) - - -(define (fix-base loc-arg prefixes base-or-bases suffixes) +(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 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))) @@ -102,17 +66,17 @@ (define (prefix-id #:source [loc-arg #f] . args) ((match-lambda [(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) ((match-lambda [(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) ((match-lambda [(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 (define-check (check-stx-equal? stx1 stx2) @@ -124,44 +88,6 @@ (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) (srcloc (syntax-source stx) (syntax-line stx)