diff --git a/sugar/cache.rkt b/sugar/cache.rkt index c457bb9..6d681e5 100644 --- a/sugar/cache.rkt +++ b/sugar/cache.rkt @@ -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)))) diff --git a/sugar/debug.rkt b/sugar/debug.rkt index f0f233f..51631d4 100644 --- a/sugar/debug.rkt +++ b/sugar/debug.rkt @@ -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 ...) diff --git a/sugar/define.rkt b/sugar/define.rkt index 28bdea3..43ee32e 100644 --- a/sugar/define.rkt +++ b/sugar/define.rkt @@ -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 diff --git a/sugar/file.rkt b/sugar/file.rkt index 36fce74..2b048da 100644 --- a/sugar/file.rkt +++ b/sugar/file.rkt @@ -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)))) \ No newline at end of file + (match (remove-ext path) + [(== path) path] + [path-reduced (loop path-reduced)]))) \ No newline at end of file diff --git a/sugar/list.rkt b/sugar/list.rkt index 56c76f8..e8a08f9 100644 --- a/sugar/list.rkt +++ b/sugar/list.rkt @@ -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) diff --git a/sugar/private/syntax-utils.rkt b/sugar/private/syntax-utils.rkt index 066a7fd..ddd0ace 100644 --- a/sugar/private/syntax-utils.rkt +++ b/sugar/private/syntax-utils.rkt @@ -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")])) - + #`(NEW-ID CONTRACT (LAMBDA ARGS . NEW-BODY)))] + ;; matches zero or one arguments + [_ (raise-syntax-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))) \ No newline at end of file +(define (lambdafy stx) + (with-syntax ([(ID LAMBDA-EXP) + (values->list (normalize-definition stx (datum->syntax stx 'λ) #true #true))]) + #'(ID LAMBDA-EXP))) \ No newline at end of file diff --git a/sugar/test.rkt b/sugar/test.rkt index 6d1cc5d..09a5282 100644 --- a/sugar/test.rkt +++ b/sugar/test.rkt @@ -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 ...)))])) diff --git a/sugar/test/main.rkt b/sugar/test/main.rkt index adb8e2b..7548909 100644 --- a/sugar/test/main.rkt +++ b/sugar/test/main.rkt @@ -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) diff --git a/sugar/xml.rkt b/sugar/xml.rkt index 22dfeef..2ac95ac 100644 --- a/sugar/xml.rkt +++ b/sugar/xml.rkt @@ -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)