stylize

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))))

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 ...)

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

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))))
+    (match (remove-ext path)
+      [(== path) path]
+      [path-reduced (loop path-reduced)])))

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)

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)))
+(define (lambdafy stx)
+  (with-syntax ([(ID LAMBDA-EXP)
+                 (values->list (normalize-definition stx (datum->syntax stx 'λ) #true #true))])
+    #'(ID LAMBDA-EXP)))

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 ...)))]))

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)

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)