mbutterick
/
sugar
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

stylize

Browse Source
dev-refac-2020
Matthew Butterick 6 years ago
parent f3ba2b714b
commit f1c7a09a4f
9 changed files with 252 additions and 292 deletions
Show Stats Download Patch File Download Diff File

11
sugar/cache.rkt
Unescape Escape View File

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

35
sugar/debug.rkt
Unescape Escape View File

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

72
sugar/define.rkt
Unescape Escape View File

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

72
sugar/file.rkt
Unescape Escape View File

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

170
sugar/list.rkt
Unescape Escape View File

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

51
sugar/private/syntax-utils.rkt
Unescape Escape View File

@ -1,17 +1,16 @@
#lang racket/base #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)) (provide (except-out (all-defined-out) values->list))
(define-syntax-rule (require+provide/safe MODNAME ...)
(define-syntax-rule (require+provide/safe modname ...)
(begin (begin
(begin (begin
(require modname) (require MODNAME)
(provide (all-from-out modname)) (provide (all-from-out MODNAME))
(module+ safe (module+ safe
(require (submod modname safe)) (require (submod MODNAME safe))
(provide (all-from-out (submod modname safe))))) ...)) (provide (all-from-out (submod MODNAME safe))))) ...))
(define-syntax (values->list stx) (define-syntax (values->list stx)
(syntax-case stx () (syntax-case stx ()
@ -19,27 +18,25 @@
;; convert calling pattern to form (id contract body-exp) ;; convert calling pattern to form (id contract body-exp)
;; hoist contract out of lambda-exp entirely ;; hoist contract out of lambda-exp entirely
(define-syntax-rule (lambdafy-with-contract stx) (define (lambdafy-with-contract stx)
(syntax-case 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`. ;; `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. ;; 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))]) (with-syntax ([(NEW-ID NEW-LAMBDA-EXP)
#'(new-id contract new-lambda-exp))] (values->list (normalize-definition #'(_ ID-EXP LAMBDA-EXP) (datum->syntax stx 'λ) #t #t))])
#'(NEW-ID CONTRACT NEW-LAMBDA-EXP))]
[(_ id-exp maybe-contract body-exp (... ...)) ; matches two, or four or more ;; matches two or more args (three-arg case handled above)
(with-syntax ([(id (lambda args contract body-exp (... ...))) (values->list (normalize-definition stx (datum->syntax #'id-exp 'λ) #t #t))]) [(_ 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 ;; 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) ;; so `syntax/loc` applies the original srcloc (associated with args and body-exp)
#`(id contract #,(syntax/loc stx (lambda args body-exp (... ...)))))] #`(NEW-ID CONTRACT (LAMBDA ARGS . NEW-BODY)))]
;; matches zero or one arguments
[else ; matches zero or one arugments [_ (raise-syntax-error 'define-macro "not enough arguments")]))
(error 'define-macro "not enough arguments")]))
(define (lambdafy stx)
(with-syntax ([(ID LAMBDA-EXP)
;; convert calling pattern to form (id body-exp) (values->list (normalize-definition stx (datum->syntax stx 'λ) #true #true))])
(define-syntax-rule (lambdafy stx) #'(ID LAMBDA-EXP)))
(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)))

52
sugar/test.rkt
Unescape Escape View File

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

22
sugar/test/main.rkt
Unescape Escape View File

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

19
sugar/xml.rkt
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save