dev-refac-2020
Matthew Butterick 6 years ago
parent f3ba2b714b
commit f1c7a09a4f

@ -1,6 +1,8 @@
#lang racket/base
(require (for-syntax racket/base "private/syntax-utils.rkt") "define.rkt")
(require (for-syntax
racket/base
"private/syntax-utils.rkt")
"define.rkt")
(define+provide+safe (make-caching-proc base-proc)
(procedure? . -> . procedure?)
@ -9,8 +11,7 @@
(λ (kws kw-args . args)
(hash-ref! cache (list* kws kw-args args) (λ () (keyword-apply base-proc kws kw-args args)))))))
(provide+safe define/caching)
(define-syntax (define/caching stx)
(with-syntax ([(id lambda-expr) (lambdafy stx)])
#'(define id (make-caching-proc lambda-expr))))
(with-syntax ([(ID LAMBDA-EXPR) (lambdafy stx)])
#'(define ID (make-caching-proc LAMBDA-EXPR))))

@ -1,5 +1,7 @@
#lang racket/base
(require racket/string (for-syntax racket/base) "define.rkt")
(require racket/string
(for-syntax racket/base)
"define.rkt")
(provide+safe report report/time time-name
report/line report/file
@ -20,7 +22,6 @@
(eprintf "~a = ~a\n" 'NAME (stringify-results expr-results))
(apply values expr-results))]))
(define-syntax (report/time stx)
(syntax-case stx ()
[(MACRO EXPR) #'(MACRO EXPR EXPR)]
@ -31,7 +32,6 @@
(eprintf "~a = ~a [~a]\n" 'NAME (stringify-results expr-results) (string-trim (get-output-string op)))
(apply values expr-results))]))
(define-syntax (report/line stx)
(syntax-case stx ()
[(MACRO EXPR) #'(MACRO EXPR EXPR)]
@ -40,7 +40,6 @@
(eprintf "~a = ~a on line ~a\n" 'NAME (stringify-results expr-results) #,(syntax-line #'EXPR))
(apply values expr-results))]))
(define-syntax (report/file stx)
(syntax-case stx ()
[(MACRO EXPR) #'(MACRO EXPR EXPR)]
@ -51,34 +50,29 @@
'#,(syntax-source #'EXPR))
(apply values expr-results))]))
(define-syntax-rule (define-multi-version multi-name name)
(define-syntax-rule (multi-name x (... ...))
(begin (name x) (... ...))))
(define-syntax-rule (define-multi-version MULTI-NAME NAME)
(define-syntax-rule (MULTI-NAME x (... ...))
(begin (NAME x) (... ...))))
(define-multi-version report* report)
(define-multi-version report*/line report/line)
(define-multi-version report*/file report/file)
(define-syntax report-apply
(syntax-rules ()
[(report-apply proc expr)
(let ([lst expr])
(report (apply proc lst) (apply proc expr))
(define-syntax (report-apply stx)
(syntax-case stx ()
[(_ PROC EXPR)
#'(let ([lst EXPR])
(report (apply PROC lst) (apply PROC EXPR))
lst)]
[(report-apply proc expr #:line)
(let ([lst expr])
(report (apply proc lst) (apply proc expr) #:line)
[(_ PROC EXPR #:line)
#'(let ([lst EXPR])
(report (apply PROC lst) (apply PROC EXPR) #:line)
lst)]))
(define-syntax-rule (repeat NUM EXPR ...)
(for/last ([i (in-range NUM)])
EXPR ...))
(define-syntax-rule (time-repeat NUM EXPR ...)
(time (repeat NUM EXPR ...)))
@ -110,7 +104,6 @@
#'(let ([n NUM])
(values (time-repeat n EXPR) ...))]))
(define-syntax (time-name stx)
(syntax-case stx ()
[(_ NAME EXPR ...)

@ -1,73 +1,67 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax syntax/strip-context "private/syntax-utils.rkt")
(require (for-syntax racket/base
racket/syntax
syntax/strip-context
"private/syntax-utils.rkt")
racket/contract)
(define-syntax (make-safe-module stx)
(syntax-case stx ()
[(_ [id contract])
[(_ [ID CONTRACT])
;; need to put `racket/contract` inside calling location's context
(with-syntax ([require-racket-contract (datum->syntax #'id '(require racket/contract))])
(with-syntax ([RACKET/CONTRACT (datum->syntax #'ID 'racket/contract)])
#'(module+ safe
require-racket-contract
(provide (contract-out [id contract]))))]
[(_ id)
(require RACKET/CONTRACT)
(provide (contract-out [ID CONTRACT]))))]
[(_ ID)
#'(module+ safe
(provide id))]))
(provide ID))]))
(define-syntax (define+provide+safe stx)
(with-syntax ([(id contract lambda-exp) (lambdafy-with-contract stx)])
(with-syntax ([(ID CONTRACT LAMBDA-EXP) (lambdafy-with-contract stx)])
#'(begin
(define id lambda-exp)
(provide+safe [id contract]))))
(define ID LAMBDA-EXP)
(provide+safe [ID CONTRACT]))))
;; for previously defined identifiers
;; takes args like (provide+safe [id contract]) or just (provide+safe id)
;; any number of args.
(define-syntax-rule (provide+safe thing ...)
(define-syntax-rule (provide+safe THING ...)
(begin
(provide+safe/once thing) ...))
(provide+safe/once THING) ...))
;; `provide+safe` might have interleaved ids or [id contract] args so handle them individually.
(define-syntax (provide+safe/once stx)
(with-syntax ([(id msm-arg) (syntax-case stx ()
[(_ [id contract])
#'(id [id contract])]
(with-syntax ([(ID MSM-ARG) (syntax-case stx ()
[(_ [ID contract])
#'(ID [ID contract])]
[(_ id)
#'(id id)])])
#'(begin
(provide id)
(make-safe-module msm-arg))))
(provide ID)
(make-safe-module MSM-ARG))))
(define-syntax (define+provide/contract stx)
(with-syntax* ([(id contract lambda-exp) (lambdafy-with-contract stx)]
[require-racket-contract (datum->syntax #'id '(require racket/contract))])
(with-syntax* ([(ID CONTRACT LAMBDA-EXP) (lambdafy-with-contract stx)]
[RACKET/CONTRACT (datum->syntax #'ID 'racket/contract)])
#'(begin
require-racket-contract
(provide (contract-out [id contract]))
(define id lambda-exp))))
(require RACKET/CONTRACT)
(provide (contract-out [ID CONTRACT]))
(define ID LAMBDA-EXP))))
(define-syntax (define/contract+provide stx)
(with-syntax* ([(id contract lambda-exp) (lambdafy-with-contract stx)]
[require-racket-contract (datum->syntax #'id '(require racket/contract))])
(with-syntax* ([(ID CONTRACT LAMBDA-EXP) (lambdafy-with-contract stx)]
[RACKET/CONTRACT (datum->syntax #'ID 'racket/contract)])
#'(begin
require-racket-contract
(provide id)
(define/contract id contract lambda-exp))))
(require RACKET/CONTRACT)
(provide ID)
(define/contract ID CONTRACT LAMBDA-EXP))))
(define-syntax (define+provide stx)
(with-syntax ([(id lambda-exp) (lambdafy stx)])
(with-syntax ([(ID LAMBDA-EXP) (lambdafy stx)])
#'(begin
(provide id)
(define id lambda-exp))))
(provide ID)
(define ID LAMBDA-EXP))))
(provide+safe make-safe-module
define+provide+safe

@ -1,14 +1,18 @@
#lang racket/base
(require "define.rkt" "coerce/base.rkt")
(require racket/list
racket/match
(except-in racket/path filename-extension)
"define.rkt"
"coerce/base.rkt")
;; this is identical to `filename-extension` in `racket/path`
;; but will not treat hidden files as an extension (which is a bug)
(define (filename-extension name)
(let* ([name (file-name-from-path name)]
[name (and name (path->bytes name))])
(cond [(and name (regexp-match #rx#".[.]([^.]+)$" name)) => cadr]
[else #f])))
(define filename (file-name-from-path name))
(define bytes (and name (path->bytes filename)))
(match (and name (regexp-match #rx#".[.]([^.]+)$" bytes))
[(list _ second) second]
[_ #false]))
(module+ test
(require rackunit)
@ -16,16 +20,6 @@
(check-equal? (rp:filename-extension (string->path ".foo")) #"foo") ; bad behavior
(check-false (filename-extension (string->path ".foo")))) ; good behavior
;; this is pulled in from `racket/path` to avoid the dependency
(define (file-name-from-path name)
(unless (or (path-string? name)
(path-for-some-system? name))
(raise-argument-error 'file-name-from-path "(or/c path-string? path-for-some-system?)" name))
(let-values ([(base file dir?) (split-path name)])
(and (not dir?) (path-for-some-system? file) file)))
;; does path have a certain extension, case-insensitively
(define+provide+safe (has-ext? x ext)
(pathish? stringish? . -> . boolean?)
@ -34,8 +28,8 @@
(unless (stringish? ext)
(raise-argument-error 'has-ext? "stringish?" ext))
(define ext-of-path (filename-extension (->path x)))
(and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (->string ext)))))
(and ext-of-path (string=? (string-downcase (bytes->string/utf-8 ext-of-path))
(string-downcase (->string ext)))))
;; get file extension as a string, or return #f
;; (consistent with filename-extension behavior)
@ -43,23 +37,22 @@
(pathish? . -> . (or/c #f string?))
(unless (pathish? x)
(raise-argument-error 'get-ext "pathish?" x))
(let ([fe-result (filename-extension (->path x))])
(and fe-result (bytes->string/utf-8 fe-result))))
(cond
[(filename-extension (->path x)) => bytes->string/utf-8]
[else #false]))
;; todo: add extensions
(provide+safe binary-extensions)
(define binary-extensions
(map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe)))
(define+provide+safe (has-binary-ext? x)
(pathish? . -> . boolean?)
(unless (pathish? x)
(raise-argument-error 'has-binary-ext? "pathish?" x))
(let ([x (->path x)])
(and (ormap (λ(ext) (has-ext? x ext)) binary-extensions) #t)))
(for/or ([ext (in-list binary-extensions)]
#:when (has-ext? (->path x) ext))
#true))
;; put extension on path
;; use local contract here because this function is used within module
@ -71,42 +64,35 @@
(raise-argument-error 'add-ext "stringish?" ext))
(->path (string-append (->string x) "." (->string ext))))
(define (starts-with? str starter)
(define pat (regexp (format "^~a" (regexp-quote starter))))
(and (regexp-match pat str) #t))
(and (regexp-match pat str) #true))
(define (path-hidden? path)
((->string (file-name-from-path path)) . starts-with? . "."))
(define (do what path)
(define (change-hide-state new-hide-state path)
(define reversed-path-elements (reverse (explode-path path)))
(apply build-path `(,@(reverse (cdr reversed-path-elements))
,(if (eq? what 'hide)
(format ".~a" (->string (car reversed-path-elements)))
(regexp-replace #rx"^." (->string (car reversed-path-elements)) "")))))
(apply build-path (append (reverse (cdr reversed-path-elements))
(list (if (eq? new-hide-state 'hide)
(format ".~a" (->string (car reversed-path-elements)))
(regexp-replace #rx"^." (->string (car reversed-path-elements)) ""))))))
;; take one extension off path
(define+provide+safe (remove-ext x)
(pathish? . -> . path?)
(let ([path (->path x)])
;; `path-replace-suffix` incorrectly thinks any leading dot counts as a file extension
;; when it might be a hidden path.
;; so handle hidden paths specially.
;; this is fixed in later Racket versions with `path-replace-extension`
(if (path-hidden? path)
(do 'hide (path-replace-suffix (do 'unhide path) ""))
(path-replace-suffix path ""))))
;; `path-replace-suffix` incorrectly thinks any leading dot counts as a file extension
;; when it might be a hidden path.
;; so handle hidden paths specially.
;; this is fixed in later Racket versions with `path-replace-extension`
(match (->path x)
[(? path-hidden? path) (change-hide-state 'hide (path-replace-suffix (change-hide-state 'unhide path) ""))]
[path (path-replace-suffix path "")]))
;; take all extensions off path
(define+provide+safe (remove-ext* x)
(pathish? . -> . path?)
(let loop ([path (->path x)])
(define path-out (remove-ext path))
(if (equal? path path-out)
path
(loop path-out))))
(match (remove-ext path)
[(== path) path]
[path-reduced (loop path-reduced)])))

@ -1,15 +1,23 @@
#lang racket/base
(require (for-syntax racket/base) racket/list "define.rkt")
(define (list-of-lists? xs) (and (list? xs) (andmap list? xs)))
(define (index? x) (and (integer? x) (not (negative? x))))
(define increasing-nonnegative-list? (λ(x) (and (list? x) (or (empty? x)
(apply < -1 x)))))
(define (integers? x) (and (list? x) (andmap integer? x)))
(define (negate pred) (λ(x) (not (pred x))))
(require (for-syntax
racket/base)
racket/list
racket/match
racket/function
"define.rkt")
(define (list-of-lists? x)
(match x
[(list (? list?) ...) #true]
[_ #false]))
(define (increasing-nonnegative-list? x)
(and (list? x) (or (empty? x) (apply < -1 x))))
(define (integers? x)
(match x
[(list (? integer?) ...) #true]
[_ #false]))
(define+provide+safe (trimf xs test-proc)
(list? procedure? . -> . list?)
@ -17,7 +25,6 @@
(raise-argument-error 'trimf "list?" xs))
(dropf-right (dropf xs test-proc) test-proc))
(define (slicef-and-filter-split-helper xs pred [drop-negated? #f])
(let loop ([xs xs][negating? #f][acc empty])
(cond
@ -28,42 +35,37 @@
(define subxs (if (and negating? drop-negated?) empty loop-pred-xs))
(loop other-xs (not negating?) (if (empty? subxs) acc (cons subxs acc)))])))
(define+provide+safe (slicef xs pred)
(list? procedure? . -> . list-of-lists?)
(unless (list? xs)
(raise-argument-error 'slicef "list?" xs))
(slicef-and-filter-split-helper xs pred))
(define+provide+safe (slicef-at xs pred [force? #f])
((list? procedure?) (boolean?) . ->* . list-of-lists?)
(unless (list? xs)
(raise-argument-error 'slicef-at "list?" xs))
(let loop ([xs xs][acc empty])
(cond
[(empty? xs) (reverse acc)]
[(pred (car xs))
(define-values (not-pred-xs rest) (splitf-at (cdr xs) (negate pred)))
(loop rest (cons (cons (car xs) not-pred-xs) acc))]
[else
(define-values (not-pred-xs rest) (splitf-at xs (negate pred)))
(loop rest (if force? acc (cons not-pred-xs acc)))])))
(match xs
[(== empty) (reverse acc)]
[(cons (? pred first) rest)
(define-values (not-pred-xs tail) (splitf-at rest (negate pred)))
(loop tail (cons (cons first not-pred-xs) acc))]
[rest
(define-values (not-pred-xs tail) (splitf-at rest (negate pred)))
(loop tail (if force? acc (cons not-pred-xs acc)))])))
(define+provide+safe (slicef-after xs pred)
(list? procedure? . -> . list-of-lists?)
(list? procedure? . -> . (listof list?))
(unless (list? xs)
(raise-argument-error 'slicef-after "list?" xs))
(let loop ([xs xs][acc empty])
(cond
[(empty? xs) (reverse acc)]
[else
(define-values (not-pred-xs rest) (splitf-at xs (negate pred)))
(if (pair? rest)
(let ([must-be-pred-x (car rest)])
(loop (cdr rest) (cons (append not-pred-xs (list must-be-pred-x)) acc)))
not-pred-xs)])))
(if (empty? xs)
(reverse acc)
(match/values (splitf-at xs (negate pred))
[(not-pred-xs (cons first-pred-x other-pred-xs))
(loop other-pred-xs (cons (append not-pred-xs (list first-pred-x)) acc))]
[(not-pred-xs _) not-pred-xs]))))
(define+provide+safe (slice-at xs len [force? #f])
((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)
@ -72,15 +74,12 @@
(unless (and (integer? len) (positive? len))
(raise-argument-error 'slice-at "positive integer for sublist length" len))
(let loop ([xs xs][slices empty])
(cond
[(< (length xs) len) (reverse
(if (or force? (empty? xs))
slices
(cons xs slices)))]
[else
(define-values (subxs rest) (split-at xs len))
(loop rest (cons subxs slices))])))
(if (< (length xs) len)
(reverse (if (or force? (empty? xs))
slices
(cons xs slices)))
(match/values (split-at xs len)
[(subxs rest) (loop rest (cons subxs slices))]))))
(define+provide+safe (filter-split xs pred)
(list? predicate/c . -> . list-of-lists?)
@ -89,81 +88,73 @@
;; same idea as slicef, but the negated items are dropped(-
(slicef-and-filter-split-helper xs (negate pred) 'drop-negated))
(define+provide+safe (frequency-hash xs)
(list? . -> . hash?)
(unless (list? xs)
(raise-argument-error 'frequency-hash "list?" xs))
(define counter (make-hash))
(for ([item (in-list xs)])
(hash-update! counter item add1 0))
(hash-update! counter item add1 0))
counter)
(define (->list x)
(cond
[(list? x) x]
[(vector? x) (vector->list x)]
[(string? x) (string->list x)]
[else (error '->list)]))
(match x
[(? list? x) x]
[(? vector?) (vector->list x)]
[(? string?) (string->list x)]
[else (raise-argument-error '->list "item that can be converted to list" x)]))
(define+provide+safe (members-unique? x)
((or/c list? vector? string?) . -> . boolean?)
(let ([x (->list x)])
(cond
[(list? x) (= (length (remove-duplicates x)) (length x))]
[else (error (format "members-unique? cannot be determined for ~a" x))])))
(match (->list x)
[(? list? x) (= (length (remove-duplicates x)) (length x))]
[_ (raise-argument-error 'members-unique? "list, vector, or string" x)]))
(define+provide+safe (members-unique?/error x)
((or/c list? vector? string?) . -> . boolean?)
(define result (members-unique? x))
(if (not result)
(let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x))
(λ(element freq) (if (> freq 1) element '()))))])
(error (string-append "members-unique? failed because " (if (= (length duplicate-keys) 1)
"item isn't"
"items aren't") " unique:") duplicate-keys))
result))
(match (members-unique? x)
[(== #false)
(define duplicate-keys (filter values (hash-map (frequency-hash (->list x))
(λ (element freq) (and (> freq 1) element)))))
(error (string-append "members-unique? failed because " (if (= (length duplicate-keys) 1)
"item isn't"
"items aren't") " unique:") duplicate-keys)]
[result result]))
(provide+safe values->list)
(define-syntax (values->list stx)
(syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
[(_ VALUES-EXPR) #'(call-with-values (λ () VALUES-EXPR) list)]))
(define+provide+safe (sublist xs i j)
(list? index? index? . -> . list?)
(list? exact-nonnegative-integer? exact-nonnegative-integer? . -> . list?)
(unless (list? xs)
(raise-argument-error 'sublist "list?" xs))
(cond
[(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))]
[(>= j i) (for/list ([(x idx) (in-indexed xs)]
#:when (<= i idx (sub1 j)))
x)]
[else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))]))
x)]
[else (raise-argument-error 'sublist (format "starting index larger than ending index" (list i j)))]))
(define+provide+safe (break-at xs bps)
(define+provide+safe (break-at xs bps-in)
(list? any/c . -> . list-of-lists?)
(unless (list? xs)
(raise-argument-error 'break-at "list?" xs))
(let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list
(when (ormap (λ (bp) (>= bp (length xs))) bps)
(raise-argument-error 'break-at
(format "breakpoints not greater than or equal to input list length = ~a" (length xs)) bps))
(when (not (increasing-nonnegative-list? bps))
(raise-argument-error 'break-at "increasing-nonnegative-list?" bps))
;; easier to do back to front, because then the list index for each item won't change during the recursion
;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition
;; because breaking at zero means we've reached the start of the list
(let loop ([xs xs][bps (reverse (cons 0 bps))][acc empty])
(if (zero? (car bps))
(cons xs acc) ; return whatever's left, because no more splits are possible
(let-values ([(head tail) (split-at xs (car bps))])
(loop head (cdr bps) (cons tail acc)))))))
(raise-argument-error 'break-at "list" xs))
(define bps ((if (list? bps-in) values list) bps-in))
(when (ormap (λ (bp) (<= (length xs) bp)) bps)
(raise-argument-error 'break-at
(format "breakpoints not greater than or equal to input list length = ~a" (length xs)) bps))
(unless (increasing-nonnegative-list? bps)
(raise-argument-error 'break-at "increasing-nonnegative-list" bps))
;; easier to do back to front, because then the list index for each item won't change during the recursion
;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition
;; because breaking at zero means we've reached the start of the list
(let loop ([xs xs][bps (reverse (cons 0 bps))][acc empty])
(match bps
[(cons (? zero?) _) (cons xs acc)] ; return whatever's left, because no more splits are possible
[_ (match/values (split-at xs (car bps))
[(head tail) (loop head (cdr bps) (cons tail acc))])])))
(define (shift-base xs how-far fill-item cycle caller)
(unless (list? xs)
@ -171,52 +162,41 @@
(define abs-how-far (if cycle
(modulo (abs how-far) (length xs))
(abs how-far)))
(define (make-fill thing) (if cycle thing (make-list abs-how-far fill-item)))
(cond
[(> abs-how-far (length xs))
(raise-argument-error caller
(format "index not larger than list length ~a" (length xs))
(* (if (eq? caller 'shift-left) -1 1) how-far))]
[(= how-far 0) xs]
[(zero? how-far) xs]
[(positive? how-far)
(define-values (head tail) (split-at-right xs abs-how-far))
(define filler (if cycle
tail
(make-list abs-how-far fill-item)))
(append filler head)]
(match/values (split-at-right xs abs-how-far)
[(head tail) (append (make-fill tail) head)])]
[else ; how-far is negative
(define-values (head tail) (split-at xs abs-how-far))
(define filler (if cycle
head
(make-list abs-how-far fill-item)))
(append tail filler)]))
(match/values (split-at xs abs-how-far)
[(head tail) (append tail (make-fill head))])]))
(define+provide+safe (shift xs how-far [fill-item #f] [cycle #f])
((list? integer?) (any/c boolean?) . ->* . list?)
(shift-base xs how-far fill-item cycle 'shift))
(define+provide+safe (shift-left xs how-far [fill-item #f] [cycle #f])
((list? integer?) (any/c boolean?) . ->* . list?)
(shift-base xs (- how-far) fill-item cycle 'shift-left))
(define+provide+safe (shift-cycle xs how-far)
(list? integer? . -> . list?)
(shift-base xs how-far #f #t 'shift-cycle))
(shift-base xs how-far #false #true 'shift-cycle))
(define+provide+safe (shift-left-cycle xs how-far)
(list? integer? . -> . list?)
(shift-base xs (- how-far) #f #t 'shift-left-cycle))
(shift-base xs (- how-far) #false #true 'shift-left-cycle))
(define+provide+safe (shifts xs how-fars [fill-item #f] [cycle #f])
((list? integers?) (any/c boolean?) . ->* . (listof list?))
(unless (list? xs)
(raise-argument-error 'shifts "list?" xs))
(map (λ(how-far) (shift xs how-far fill-item cycle)) how-fars))
(map (λ (how-far) (shift xs how-far fill-item cycle)) how-fars))
(define+provide+safe (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f])
((list? (or/c integers? integer?)) (any/c boolean?) . ->* . any)

@ -1,17 +1,16 @@
#lang racket/base
(require (for-syntax racket/base) syntax/define)
(require (for-syntax racket/base)
syntax/define)
(provide (except-out (all-defined-out) values->list))
(define-syntax-rule (require+provide/safe modname ...)
(define-syntax-rule (require+provide/safe MODNAME ...)
(begin
(begin
(require modname)
(provide (all-from-out modname))
(require MODNAME)
(provide (all-from-out MODNAME))
(module+ safe
(require (submod modname safe))
(provide (all-from-out (submod modname safe))))) ...))
(require (submod MODNAME safe))
(provide (all-from-out (submod MODNAME safe))))) ...))
(define-syntax (values->list stx)
(syntax-case stx ()
@ -19,27 +18,25 @@
;; convert calling pattern to form (id contract body-exp)
;; hoist contract out of lambda-exp entirely
(define-syntax-rule (lambdafy-with-contract stx)
(define (lambdafy-with-contract stx)
(syntax-case stx ()
[(_ id-exp contract lambda-exp) ; matches exactly three args after `define`
[(_ ID-EXP CONTRACT LAMBDA-EXP) ; matches exactly three args after `define`
;; `normalize-definition` can't handle the acceptable `define/contract` pattern of id, contract, lambda exp after the `define`.
;; so extract the contract, and then put id & lambda-exp back together, and let `normalize-definition` destructure as usual.
(with-syntax ([(new-id new-lambda-exp) (values->list (normalize-definition #'(_ id-exp lambda-exp) (datum->syntax #'id-exp 'λ) #t #t))])
#'(new-id contract new-lambda-exp))]
[(_ id-exp maybe-contract body-exp (... ...)) ; matches two, or four or more
(with-syntax ([(id (lambda args contract body-exp (... ...))) (values->list (normalize-definition stx (datum->syntax #'id-exp 'λ) #t #t))])
(with-syntax ([(NEW-ID NEW-LAMBDA-EXP)
(values->list (normalize-definition #'(_ ID-EXP LAMBDA-EXP) (datum->syntax stx 'λ) #t #t))])
#'(NEW-ID CONTRACT NEW-LAMBDA-EXP))]
;; matches two or more args (three-arg case handled above)
[(_ ID-EXP . BODY)
(with-syntax ([(NEW-ID (LAMBDA ARGS CONTRACT . NEW-BODY))
(values->list (normalize-definition stx (datum->syntax stx 'λ) #t #t))])
;; because the macro provides the `lambda` below, it takes the local srcloc by default
;; so `syntax/loc` applies the original srcloc (associated with args and body-exp)
#`(id contract #,(syntax/loc stx (lambda args body-exp (... ...)))))]
[else ; matches zero or one arugments
(error 'define-macro "not enough arguments")]))
;; convert calling pattern to form (id body-exp)
(define-syntax-rule (lambdafy stx)
(with-syntax ([(id lambda-exp) (let-values ([(id-stx body-exp-stx) (normalize-definition stx (datum->syntax stx 'λ) #t #t)])
(list id-stx body-exp-stx))])
#'(id lambda-exp)))
#`(NEW-ID CONTRACT (LAMBDA ARGS . NEW-BODY)))]
;; matches zero or one arguments
[_ (raise-syntax-error 'define-macro "not enough arguments")]))
(define (lambdafy stx)
(with-syntax ([(ID LAMBDA-EXP)
(values->list (normalize-definition stx (datum->syntax stx 'λ) #true #true))])
#'(ID LAMBDA-EXP)))

@ -1,40 +1,44 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax))
(require "define.rkt")
(provide+safe module-test-external module-test-internal module-test-internal+external)
(require (for-syntax
racket/base
racket/syntax
syntax/strip-context)
"define.rkt")
(provide+safe module-test-external
module-test-internal
module-test-internal+external)
;; tests using module-boundary contracts
(define-syntax (module-test-external stx)
(syntax-case stx ()
[(_ expr ...)
(let ([mod-name (syntax-e (generate-temporary))])
(datum->syntax stx
`(begin
(module* ,mod-name racket/base
(require (submod ".."))
(require rackunit)
,@(syntax->datum #'(expr ...)))
(module+ test
(require (submod ".." ,mod-name))))
stx))]))
[(_ EXPR ...)
(replace-context
stx
(with-syntax ([MOD-NAME (syntax-e (generate-temporary))])
#'(begin
(module* MOD-NAME racket/base
(require (submod ".."))
(require rackunit)
EXPR ...)
(module+ test
(require (submod ".." MOD-NAME))))))]))
(define-syntax (module-test-internal stx)
(syntax-case stx ()
[(_ expr ...)
(let ([exprs (syntax->datum #'(expr ...))])
(datum->syntax stx `(begin
(module+ test
(require rackunit)
,@exprs))
;; pass original stx for srcloc
;; which is not precisely accurate but
;; OK for now
stx))]))
[(_ EXPR ...)
(replace-context
stx
#'(begin
(module+ test
(require rackunit)
EXPR ...)))]))
(define-syntax (module-test-internal+external stx)
(syntax-case stx ()
[(_ expr ...)
(let ([exprs (syntax->datum #'(expr ...))])
(datum->syntax stx `(begin
(module-test-internal ,@exprs)
(module-test-external ,@exprs)) stx))]))
[(_ EXPR ...)
(replace-context
stx
#'(begin
(module-test-internal EXPR ...)
(module-test-external EXPR ...)))]))

@ -1,22 +1,22 @@
#lang racket
(require (for-syntax racket/syntax syntax/strip-context))
(require (for-syntax racket/syntax
syntax/strip-context))
(define-syntax (eval-with-and-without-contracts stx)
(syntax-case stx ()
[(_ exprs ...)
(with-syntax ([module-without-contracts (generate-temporary)]
[module-with-contracts (generate-temporary)])
[(_ EXPRS ...)
(with-syntax ([MODULE-WITHOUT-CONTRACTS (generate-temporary)]
[MODULE-WITH-CONTRACTS (generate-temporary)])
(replace-context stx
#'(begin
(module module-without-contracts racket
(module MODULE-WITHOUT-CONTRACTS racket
(require rackunit "../main.rkt" net/url)
exprs ...)
(require 'module-without-contracts)
(module module-with-contracts racket
EXPRS ...)
(require 'MODULE-WITHOUT-CONTRACTS)
(module MODULE-WITH-CONTRACTS racket
(require rackunit (submod "../main.rkt" safe) net/url)
exprs ...)
(require 'module-with-contracts))))]))
EXPRS ...)
(require 'MODULE-WITH-CONTRACTS))))]))
(eval-with-and-without-contracts
(check-equal? (->int 42) 42)

@ -1,18 +1,23 @@
#lang racket/base
(require xml racket/port racket/contract "define.rkt")
(require xml
racket/port
racket/contract
"define.rkt")
(provide (all-defined-out))
(define+provide+safe (xml-string->xexprs str)
(string? . -> . (values xexpr? xexpr?))
(define xml-doc (with-input-from-string str
(λ () (permissive-xexprs #t) (read-xml))))
(values (xml->xexpr (document-prolog xml-doc)) (xml->xexpr (document-element xml-doc))))
(parameterize ([current-input-port (open-input-string str)]
[permissive-xexprs #true])
(define xml-doc (read-xml))
(values (xml->xexpr (document-prolog xml-doc)) (xml->xexpr (document-element xml-doc)))))
(define+provide+safe (xexprs->xml-string prolog-xexpr root-xexpr)
(xexpr? xexpr? . -> . string?)
(with-output-to-string (λ () (write-xml (document (xexpr->xml prolog-xexpr) (xexpr->xml root-xexpr) null)))))
(with-output-to-string
(λ ()
(parameterize ([permissive-xexprs #true])
(write-xml (document (xexpr->xml prolog-xexpr) (xexpr->xml root-xexpr) null))))))
(module+ test
(require rackunit)

Loading…
Cancel
Save