├── sugar ├── unstable │ ├── no-lang-line-source.txt │ ├── source.rkt │ ├── case.rkt │ ├── contract.rkt │ ├── dict.rkt │ ├── port.rkt │ ├── misc.rkt │ ├── string.rkt │ ├── stub.rkt │ ├── len.rkt │ ├── js.rkt │ ├── class.rkt │ ├── container.rkt │ └── include.rkt ├── info.rkt ├── coerce.rkt ├── scribblings │ ├── installation.scrbl │ ├── license.scrbl │ ├── include.scrbl │ ├── len.scrbl │ ├── sugar.scrbl │ ├── string.scrbl │ ├── xml.scrbl │ ├── cache.scrbl │ ├── file-extensions.scrbl │ ├── container.scrbl │ ├── debug.scrbl │ ├── coerce.scrbl │ └── list.scrbl ├── main.rkt ├── test │ ├── debug-meta-lang.rkt │ ├── test-require-modes.rkt │ └── main.rkt ├── cache.rkt ├── xml.rkt ├── test.rkt ├── coerce │ ├── contract.rkt │ └── base.rkt ├── private │ └── syntax-utils.rkt ├── define.rkt ├── file.rkt ├── debug.rkt └── list.rkt ├── info.rkt ├── .gitignore ├── README.md ├── LICENSE.md └── .github └── workflows └── ci.yml /sugar/unstable/no-lang-line-source.txt: -------------------------------------------------------------------------------- 1 | (define no-lang-symbol 'bar) -------------------------------------------------------------------------------- /sugar/unstable/source.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define included-symbol 'bar) -------------------------------------------------------------------------------- /sugar/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define scribblings '(("scribblings/sugar.scrbl" ()))) 3 | (define compile-omit-paths '("test")) 4 | -------------------------------------------------------------------------------- /sugar/coerce.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/syntax-utils.rkt") 3 | 4 | (require+provide/safe "coerce/base.rkt" "coerce/contract.rkt") 5 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define version "0.3") 4 | (define deps '("base")) 5 | (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib")) 6 | -------------------------------------------------------------------------------- /sugar/scribblings/installation.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | 4 | @title{Installation & updates} 5 | 6 | At the command line: 7 | @verbatim{raco pkg install sugar} 8 | 9 | After that, you can update the package from the command line: 10 | @verbatim{raco pkg update sugar} -------------------------------------------------------------------------------- /sugar/scribblings/license.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title{License & source code} 4 | 5 | This module is licensed under the LGPL. 6 | 7 | Source repository at @link["http://github.com/mbutterick/sugar"]{http://github.com/mbutterick/sugar}. Suggestions & corrections welcome. 8 | 9 | -------------------------------------------------------------------------------- /sugar/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/syntax-utils.rkt") 3 | 4 | (require+provide/safe "cache.rkt" 5 | "coerce.rkt" 6 | "debug.rkt" 7 | "define.rkt" 8 | "file.rkt" 9 | "list.rkt" 10 | "test.rkt" 11 | "xml.rkt") 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # for Racket 2 | compiled/ 3 | *~ 4 | 5 | # for Mac OS X 6 | .DS_Store 7 | .AppleDouble 8 | .LSOverride 9 | Icon 10 | 11 | # Thumbnails 12 | ._* 13 | 14 | # Files that might appear on external disk 15 | .Spotlight-V100 16 | .Trashes 17 | 18 | # generated documentation 19 | sugar/doc/* 20 | sugar/scribblings/*.js 21 | sugar/scribblings/*.css 22 | sugar/scribblings/*.html 23 | -------------------------------------------------------------------------------- /sugar/scribblings/include.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @title{Include} 6 | @defmodule[sugar/include] 7 | 8 | @defform[(include-without-lang-line path-spec)] 9 | Inline the syntax in the file designated by @racket[_path-spec], after stripping off the @tt{#lang} line of the file (if it exists, otherwise just @racket[include] the file as usual). -------------------------------------------------------------------------------- /sugar/test/debug-meta-lang.rkt: -------------------------------------------------------------------------------- 1 | #lang sugar/debug racket 2 | (require rackunit) 3 | (let ([out (open-output-string)] 4 | [let "something else"] 5 | [local-require "something else entirely"] 6 | [only-in "completely unexpected!"] 7 | [report "well, not really"]) 8 | (parameterize ([current-error-port out]) 9 | #R5) 10 | (check-equal? (get-output-string out) "5 = 5\n")) 11 | (let ([out (open-output-string)] 12 | [report/line "outta the blue!"]) 13 | (parameterize ([current-error-port out]) 14 | #RR5) 15 | (check-equal? (get-output-string out) "5 = 5 on line 14\n")) 16 | -------------------------------------------------------------------------------- /sugar/unstable/case.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base racket/syntax)) 3 | (provide (all-defined-out)) 4 | 5 | ;; like case but strictly uses `eq?` comparison (as opposed to `equal?`) 6 | (define-syntax caseq (make-rename-transformer #'case)) 7 | (define-syntax casev (make-rename-transformer #'case)) 8 | 9 | 10 | (require sugar/debug) 11 | (define-syntax (cond-report stx) 12 | (syntax-case stx () 13 | [(_ [COND . BODY] ... [else . ELSE-BODY]) #'(cond [(report COND) (report (let () (void) . BODY))] ... [else . ELSE-BODY])] 14 | [(_ [COND . BODY] ... ) #'(cond-report [COND . BODY] ... [else (void)])])) 15 | -------------------------------------------------------------------------------- /sugar/cache.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax 3 | racket/base 4 | "private/syntax-utils.rkt") 5 | "define.rkt") 6 | 7 | (define+provide+safe (make-caching-proc base-proc) 8 | (procedure? . -> . procedure?) 9 | (let ([cache (make-hash)]) 10 | (make-keyword-procedure 11 | (λ (kws kw-args . args) 12 | (hash-ref! cache (list* kws kw-args args) (λ () (keyword-apply base-proc kws kw-args args))))))) 13 | 14 | (provide+safe define/caching) 15 | (define-syntax (define/caching stx) 16 | (with-syntax ([(ID LAMBDA-EXPR) (lambdafy stx)]) 17 | #'(define ID (make-caching-proc LAMBDA-EXPR)))) 18 | -------------------------------------------------------------------------------- /sugar/unstable/contract.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract racket/class) 3 | (provide (all-defined-out)) 4 | 5 | (define (option/c x) (or/c #f x)) 6 | 7 | (module+ main 8 | 9 | (define-syntax-rule (define/public/contract (ID . ARGS) CONTRACT . BODY) 10 | (define/public (ID . ARGS) 11 | (define/contract (ID . ARGS) 12 | CONTRACT . BODY) 13 | (ID . ARGS))) 14 | 15 | (define c% (class object% 16 | (super-new) 17 | 18 | (define/public/contract (add x y) 19 | (integer? integer? . -> . integer?) 20 | (+ x y)))) 21 | 22 | 23 | (define c (make-object c%)) 24 | 25 | (send c add 12 21)) -------------------------------------------------------------------------------- /sugar/test/test-require-modes.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require rackunit) 3 | 4 | (module rb racket/base 5 | (require (submod sugar/list safe) rackunit) 6 | (provide (all-defined-out)) 7 | (check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at trimf 8 | (define foo (trimf '(1 2 3) odd?)) 9 | (check-equal? foo '(2))) 10 | 11 | (module rbu racket/base 12 | (require sugar/list rackunit) 13 | (provide (all-defined-out)) 14 | (check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at dropf 15 | (define foo (trimf '(1 2 3) odd?)) 16 | (check-equal? foo '(2))) 17 | 18 | (require (prefix-in rb: 'rb)) 19 | (require (prefix-in rbu: 'rbu)) 20 | 21 | (check-true (andmap (λ(val) (equal? val '(2))) (list rb:foo rbu:foo))) -------------------------------------------------------------------------------- /sugar/unstable/dict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require sugar/list) 3 | (provide (all-defined-out)) 4 | 5 | (define (assoc? x) (and (pair? x) (not (list? x)))) 6 | (define (assocs? xs) (and (list? xs) (andmap assoc? xs))) 7 | 8 | (define (listify kvs) 9 | (for/list ([slice (in-list (slice-at kvs 2))]) 10 | (cons (car slice) (cadr slice)))) 11 | (define-syntax-rule (define-hashifier id hasher) (define (id . kvs) (hasher (listify kvs)))) 12 | 13 | ;; like indefinite-arity `hash` but mutable 14 | (define-hashifier mhash make-hash) 15 | (define-hashifier mhasheq make-hasheq) 16 | (define-hashifier mhasheqv make-hasheqv) 17 | 18 | (module+ test 19 | (require rackunit) 20 | (check-equal? (mhash 'k "v") (make-hash (list (cons 'k "v"))))) 21 | 22 | (define (dictify . xs) (listify xs)) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Sugar ![Build Status](https://github.com/mbutterick/sugar/workflows/CI/badge.svg) 2 | 3 | Functions that improve the readability of Racket code in Racket 6.0+. 4 | 5 | Install from the command line like so: 6 | 7 | raco pkg install sugar 8 | 9 | Then require it in your Racket file, in standard mode: 10 | 11 | (require sugar) 12 | 13 | In safe mode (with contracts): 14 | 15 | (require (submod sugar safe)) 16 | 17 | You can [read the docs here](http://pkg-build.racket-lang.org/doc/sugar). 18 | 19 | 20 | ## License 21 | 22 | MIT 23 | 24 | ## Project status 25 | 26 | Complete. Maintained but no improvements planned. I don’t disavow this code, exactly, and I maintain other projects that rely on it. But it arises from a more naive era of personal Racketeering. I would not necessarily recommend taking inspiration from the code herein. 27 | -------------------------------------------------------------------------------- /sugar/unstable/port.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/port) 3 | (provide (all-defined-out) (all-from-out racket/port)) 4 | 5 | (define (port-position ip [where #f]) 6 | (cond 7 | [where (file-position ip where) 8 | ip] 9 | [else (file-position ip)])) 10 | 11 | (define (set-port-position! ip where) 12 | (file-position ip where)) 13 | 14 | (module+ test 15 | (require rackunit) 16 | (define ip (open-input-bytes (bytes 1 2 3 4))) 17 | (port-count-lines! ip) 18 | (check-equal? (port-position ip) 0) 19 | (check-equal? (read-byte ip) 1) 20 | (check-equal? (port-position ip) 1) 21 | (check-equal? (read-byte ip) 2) 22 | (set-port-position! ip 4) 23 | (check-equal? (port-position ip) 4) 24 | (check-equal? (read-byte ip) eof) 25 | (set-port-position! ip 0) 26 | (check-equal? (port-position ip) 0) 27 | (check-equal? (read-byte ip) 1)) -------------------------------------------------------------------------------- /sugar/scribblings/len.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{Len} 9 | @defmodule[#:multi (sugar/len (submod sugar/len safe))] 10 | 11 | 12 | @defproc[ 13 | (len 14 | [x (or/c list? vector? set? string? symbol? path? hash?)]) 15 | integer?] 16 | Calculate the length of @racket[_x] in the least surprising way possible, or if it can't be done, raise an error. Named in honor of the original discoverer of the length-reticulation algorithm, Prof. Leonard Spottiswoode. 17 | 18 | @examples[#:eval my-eval 19 | (len '(a b c)) 20 | (len (list->vector '(a b c))) 21 | (len 'abc) 22 | (len "abc") 23 | (len (string->path "abc")) 24 | (len (make-hash `((a . 1)(b . 2)(c . 3)))) 25 | ] 26 | 27 | Perhaps ironically, positive integers do not have a length. 28 | 29 | @examples[#:eval my-eval 30 | (len 3)] -------------------------------------------------------------------------------- /sugar/scribblings/sugar.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | 9 | @title[#:style 'toc]{Sugar} 10 | 11 | @author[(author+email "Matthew Butterick" "mb@mbtype.com")] 12 | 13 | @defmodule[#:multi (sugar (submod sugar safe))] 14 | 15 | A collection of small functions to help make Racket code simpler & more readable. Well, according to me, anyhow. 16 | 17 | Sugar can be invoked two ways: as an ordinary library, or as a library with contracts (using the @tt{safe} submodule). 18 | 19 | 20 | @;local-table-of-contents[] 21 | 22 | @include-section["installation.scrbl"] 23 | 24 | @include-section["cache.scrbl"] 25 | 26 | @include-section["coerce.scrbl"] 27 | 28 | @include-section["debug.scrbl"] 29 | 30 | @include-section["file-extensions.scrbl"] 31 | 32 | @include-section["list.scrbl"] 33 | 34 | @include-section["xml.scrbl"] 35 | 36 | @include-section["license.scrbl"] 37 | 38 | @;index-section[] 39 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License for `sugar` 2 | 3 | © 2014-2019 Matthew Butterick 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 6 | 7 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 8 | 9 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 10 | -------------------------------------------------------------------------------- /sugar/unstable/misc.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../define.rkt" racket/set "../coerce.rkt") 3 | 4 | 5 | (define+provide+safe (bytecount->string bytecount) 6 | (integer? . -> . string?) 7 | (define (format-with-threshold threshold suffix) 8 | ;; upconvert by factor of 100 to get two digits after decimal 9 | (format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix)) 10 | 11 | (define threshold-kilobyte 1000) 12 | (define threshold-megabyte (threshold-kilobyte . * . threshold-kilobyte)) 13 | (define threshold-gigabyte (threshold-megabyte . * . threshold-kilobyte)) 14 | (define threshold-terabyte (threshold-gigabyte . * . threshold-kilobyte)) 15 | 16 | (cond 17 | [(bytecount . >= . threshold-terabyte) (format-with-threshold threshold-terabyte "TB")] 18 | [(bytecount . >= . threshold-gigabyte) (format-with-threshold threshold-gigabyte "GB")] 19 | [(bytecount . >= . threshold-megabyte) (format-with-threshold threshold-megabyte "MB")] 20 | [(bytecount . >= . threshold-kilobyte) (format-with-threshold threshold-kilobyte "KB")] 21 | [else (format "~a bytes" bytecount)])) -------------------------------------------------------------------------------- /sugar/xml.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require xml 3 | racket/port 4 | racket/contract 5 | "define.rkt") 6 | (provide (all-defined-out)) 7 | 8 | (define+provide+safe (xml-string->xexprs str) 9 | (string? . -> . (values xexpr? xexpr?)) 10 | (parameterize ([current-input-port (open-input-string str)] 11 | [permissive-xexprs #true]) 12 | (define xml-doc (read-xml)) 13 | (values (xml->xexpr (document-prolog xml-doc)) (xml->xexpr (document-element xml-doc))))) 14 | 15 | (define+provide+safe (xexprs->xml-string prolog-xexpr root-xexpr) 16 | (xexpr? xexpr? . -> . string?) 17 | (with-output-to-string 18 | (λ () 19 | (parameterize ([permissive-xexprs #true]) 20 | (write-xml (document (xexpr->xml prolog-xexpr) (xexpr->xml root-xexpr) null)))))) 21 | 22 | (module+ test 23 | (require rackunit) 24 | (require xml) 25 | (define str "\nhello world") 26 | (define-values (str-prolog str-doc) (xml-string->xexprs str)) 27 | (check-equal? str-prolog (prolog (list (p-i (location 1 0 1) (location 1 38 39) 'xml "version=\"1.0\" encoding=\"utf-8\"")) #f null)) 28 | (check-equal? str-doc '(root () "hello world")) 29 | (check-equal? (xexprs->xml-string str-prolog str-doc) str)) 30 | -------------------------------------------------------------------------------- /sugar/scribblings/string.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{String} 9 | @defmodule[#:multi (sugar/string (submod sugar/string safe))] 10 | 11 | 12 | @defproc[ 13 | (starts-with? 14 | [str stringish?] 15 | [starter stringish?]) 16 | boolean?] 17 | Return @racket[#t] if @racket[_str] starts with @racket[_starter], otherwise @racket[#f]. 18 | 19 | @examples[#:eval my-eval 20 | (starts-with? "foobar" "foo") 21 | (starts-with? "foobar" "foobar") 22 | (starts-with? "foobar" "zam") 23 | (starts-with? "foobar" "foobars") 24 | ] 25 | 26 | 27 | @defproc[ 28 | (ends-with? 29 | [str stringish?] 30 | [ender stringish?]) 31 | boolean?] 32 | Return @racket[#t] if @racket[_str] ends with @racket[_ender], otherwise @racket[#f]. 33 | 34 | @examples[#:eval my-eval 35 | (ends-with? "foobar" "foo") 36 | (ends-with? "foobar" "foobar") 37 | (ends-with? "foobar" "zam") 38 | (ends-with? "foobar" "foobars") 39 | ] 40 | 41 | 42 | @defproc[ 43 | (capitalized? 44 | [str stringish?]) 45 | boolean?] 46 | Return @racket[#t] if @racket[_str] starts with a capital letter, otherwise @racket[#f]. 47 | 48 | @examples[#:eval my-eval 49 | (capitalized? "Brennan") 50 | (capitalized? "Brennan stinks") 51 | (capitalized? "stinks") 52 | ] 53 | 54 | -------------------------------------------------------------------------------- /sugar/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax 3 | racket/base 4 | racket/syntax 5 | syntax/strip-context) 6 | "define.rkt") 7 | 8 | (provide+safe module-test-external 9 | module-test-internal 10 | module-test-internal+external) 11 | 12 | ;; tests using module-boundary contracts 13 | (define-syntax (module-test-external stx) 14 | (syntax-case stx () 15 | [(_ EXPR ...) 16 | (replace-context 17 | stx 18 | (with-syntax ([MOD-NAME (syntax-e (generate-temporary))]) 19 | #'(begin 20 | (module* MOD-NAME racket/base 21 | (require (submod "..")) 22 | (require rackunit) 23 | EXPR ...) 24 | (module+ test 25 | (require (submod ".." MOD-NAME))))))])) 26 | 27 | (define-syntax (module-test-internal stx) 28 | (syntax-case stx () 29 | [(_ EXPR ...) 30 | (replace-context 31 | stx 32 | #'(begin 33 | (module+ test 34 | (require rackunit) 35 | EXPR ...)))])) 36 | 37 | (define-syntax (module-test-internal+external stx) 38 | (syntax-case stx () 39 | [(_ EXPR ...) 40 | (replace-context 41 | stx 42 | #'(begin 43 | (module-test-internal EXPR ...) 44 | (module-test-external EXPR ...)))])) 45 | -------------------------------------------------------------------------------- /sugar/unstable/string.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../define.rkt" "../coerce.rkt") 3 | 4 | 5 | (define+provide+safe (starts-with? str starter) 6 | (string? string? . -> . coerce/boolean?) 7 | (define pat (regexp (format "^~a" (regexp-quote starter)))) 8 | (and (regexp-match pat (->string str)) #t)) 9 | 10 | 11 | (define+provide+safe (ends-with? str ender) 12 | (string? string? . -> . coerce/boolean?) 13 | (define pat (regexp (format "~a$" (regexp-quote ender)))) 14 | (and (regexp-match pat (->string str)) #t)) 15 | 16 | 17 | (define+provide+safe (capitalized? str-in) 18 | (string? . -> . coerce/boolean?) 19 | (define str (->string str-in)) 20 | (and (positive? (string-length str)) 21 | (char-upper-case? (car (string->list (car (regexp-match "." str))))))) 22 | 23 | 24 | (module+ test 25 | (require rackunit) 26 | (check-true (starts-with? "foobar" "foo")) 27 | (check-true (starts-with? "foobar" "foobar")) 28 | (check-false (starts-with? "foobar" "zam")) 29 | (check-false (starts-with? "foobar" "foobars")) 30 | (check-false (starts-with? "foo" ".")) 31 | (check-true (ends-with? "foobar" "bar")) 32 | (check-false (ends-with? "foobar" "zam")) 33 | (check-true (ends-with? "foobar" "foobar")) 34 | (check-false (ends-with? "foobar" "foobars")) 35 | (check-true (capitalized? "Brennan")) 36 | (check-false (capitalized? "foobar"))) 37 | 38 | -------------------------------------------------------------------------------- /sugar/unstable/stub.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base racket/syntax)) 3 | (provide (all-defined-out)) 4 | 5 | (begin-for-syntax 6 | (require racket/string racket/format) 7 | (define (make-prefix caller-stx) 8 | (string-join (map ~a (list (syntax-source caller-stx) (syntax-line caller-stx))) ":" #:after-last ":"))) 9 | 10 | (define-syntax (define-stub-stop stx) 11 | (syntax-case stx () 12 | [(_ ID) 13 | (with-syntax ([ERROR-ID (format-id stx "~a~a:not-implemented" (make-prefix stx) (syntax->datum #'ID))]) 14 | #'(define (ID . args) 15 | (error 'ERROR-ID)))])) 16 | 17 | (provide (rename-out [define-stub-stop define-stub])) 18 | 19 | (define-syntax (define-stub-go stx) 20 | (syntax-case stx () 21 | [(_ ID) 22 | (with-syntax ([ERROR-ID (format-id stx "~a~a:not-implemented" (make-prefix stx) (syntax->datum #'ID))]) 23 | #'(define (ID . args) 24 | (displayln 'ERROR-ID)))])) 25 | 26 | (define-syntax (define-unfinished stx) 27 | (syntax-case stx () 28 | [(_ (ID . ARGS) . BODY) 29 | (with-syntax ([ID-UNFINISHED (format-id stx "~a~a:unfinished" (make-prefix stx) (syntax->datum #'ID))]) 30 | #'(define (ID . ARGS) 31 | (begin . BODY) 32 | (error 'ID-UNFINISHED)))])) 33 | 34 | 35 | (define-syntax (unfinished stx) 36 | (syntax-case stx () 37 | [(_) 38 | (with-syntax ([ID-UNFINISHED (format-id stx "~a:~a:~a" (path->string (syntax-source stx)) (syntax-line stx) (syntax->datum #'unfinished))]) 39 | #'(error 'ID-UNFINISHED))])) -------------------------------------------------------------------------------- /sugar/scribblings/xml.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar xml)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{XML} 9 | @defmodule[#:multi (sugar/xml (submod sugar/xml safe))] 10 | 11 | 12 | Making it easier to do the simplest kind of round-trip with XML: convert an XML string to X-expressions, manipulate, and then convert these X-expressions back to an XML string. 13 | 14 | @defproc[ 15 | (xml-string->xexprs 16 | [xml-string string?]) 17 | (values xexpr? xexpr?)] 18 | Take a string containg XML and break it into two X-expressions: one representing the prolog of the document, and the other representing everything under the root node. Your @racket[_xml-string] must have a root node, but it doesn't need a prolog. 19 | 20 | @examples[#:eval my-eval 21 | (define str "\nhello") 22 | (xml-string->xexprs str) 23 | (define root-only "hello") 24 | (xml-string->xexprs root-only) 25 | (define prolog-only "") 26 | (xml-string->xexprs prolog-only) 27 | ] 28 | 29 | 30 | @defproc[ 31 | (xexprs->xml-string 32 | [prolog-xexpr xexpr?] 33 | [root-xexpr xexpr?]) 34 | string?] 35 | Take two X-expressions representing the prolog and root of an XML document and join them back into an XML string. In other words, the inverse of the function above. 36 | 37 | @examples[#:eval my-eval 38 | (define str "\nhello") 39 | (define-values (prolog doc) (xml-string->xexprs str)) 40 | prolog 41 | doc 42 | (xexprs->xml-string prolog doc)] 43 | 44 | -------------------------------------------------------------------------------- /sugar/coerce/contract.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base racket/syntax) racket/contract "../define.rkt" "base.rkt") 3 | 4 | 5 | (define-syntax-rule (make-blame-handler PROC EXPECTED) 6 | (λ (b) 7 | (λ (x) (with-handlers ([exn:fail? (λ (exn) 8 | (raise-blame-error b x 9 | '(expected: "~a" given: "~e") 10 | EXPECTED x))]) 11 | (PROC x))))) 12 | 13 | 14 | (provide+safe make-coercion-contract) 15 | (define-syntax (make-coercion-contract stx) 16 | (syntax-case stx () 17 | [(_ STEM COERCE-PROC) 18 | (with-syntax ([COERCE/STEM? (format-id stx "coerce/~a?" #'STEM)] 19 | [STEMISH? (format-id stx "~aish?" #'STEM)]) 20 | #'(make-contract 21 | #:name 'COERCE/STEM? 22 | #:projection (make-blame-handler COERCE-PROC 'STEMISH?)))] 23 | [(MACRO-NAME STEM) 24 | (with-syntax ([->STEM (format-id stx "->~a" #'STEM)]) 25 | #'(MACRO-NAME STEM ->STEM))])) 26 | 27 | 28 | (define-syntax (define+provide-coercion-contract stx) 29 | (syntax-case stx () 30 | [(_ STEM) 31 | (with-syntax ([COERCE/STEM? (format-id stx "coerce/~a?" #'STEM)]) 32 | #'(begin 33 | (provide+safe COERCE/STEM?) 34 | (define COERCE/STEM? (make-coercion-contract STEM))))])) 35 | 36 | 37 | (define-syntax-rule (define+provide-coercion-contracts STEM ...) 38 | (begin (define+provide-coercion-contract STEM) ...)) 39 | 40 | 41 | (define+provide-coercion-contracts int 42 | string 43 | symbol 44 | path 45 | boolean 46 | list) 47 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | run: 7 | name: "Build using Racket '${{ matrix.racket-version }}' (${{ matrix.racket-variant }})" 8 | runs-on: ubuntu-latest 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | racket-version: ["6.6", "6.7", "6.8", "6.9", "6.10.1", "6.11", "6.12", "7.0", "7.1", "7.2", "7.3", "7.4", "7.5", "7.6", "7.7", "7.8", "7.9", "current"] 13 | racket-variant: ["BC", "CS"] 14 | # CS builds are only provided for versions 7.4 and up so avoid 15 | # running the job for prior versions. 16 | exclude: 17 | - {racket-version: "6.6", racket-variant: "CS"} 18 | - {racket-version: "6.7", racket-variant: "CS"} 19 | - {racket-version: "6.8", racket-variant: "CS"} 20 | - {racket-version: "6.9", racket-variant: "CS"} 21 | - {racket-version: "6.10.1", racket-variant: "CS"} 22 | - {racket-version: "6.11", racket-variant: "CS"} 23 | - {racket-version: "6.12", racket-variant: "CS"} 24 | - {racket-version: "7.0", racket-variant: "CS"} 25 | - {racket-version: "7.1", racket-variant: "CS"} 26 | - {racket-version: "7.2", racket-variant: "CS"} 27 | - {racket-version: "7.3", racket-variant: "CS"} 28 | 29 | steps: 30 | - name: Checkout 31 | uses: actions/checkout@master 32 | 33 | - uses: Bogdanp/setup-racket@v0.11 34 | with: 35 | distribution: 'full' 36 | version: ${{ matrix.racket-version }} 37 | variant: ${{ matrix.racket-variant }} 38 | 39 | - name: Install Sugar and its dependencies 40 | run: raco pkg install --auto --batch 41 | 42 | - name: Run the tests 43 | run: xvfb-run raco test -j 4 -p sugar 44 | -------------------------------------------------------------------------------- /sugar/unstable/len.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax 3 | racket/base 4 | racket/syntax) 5 | "../define.rkt" 6 | racket/sequence 7 | racket/generic) 8 | 9 | 10 | (provide define-generics+provide+safe) 11 | (define-syntax (define-generics+provide+safe stx) 12 | (syntax-case stx () 13 | [(_ TYPE ID-CONTRACT (ID . ID-ARGS) . ARGS) 14 | (with-syntax ([TYPE? (format-id stx "~a?" #'TYPE)]) 15 | #'(begin 16 | (provide TYPE? ID) 17 | (module+ safe 18 | (require racket/contract) 19 | (provide TYPE? (contract-out [ID ID-CONTRACT]))) 20 | (define-generics TYPE (ID . ID-ARGS) . ARGS)))])) 21 | 22 | (provide len lengthable?) 23 | (define-generics lengthable 24 | (len lengthable) 25 | #:fast-defaults 26 | ([list? (define len length)] 27 | [string? (define len string-length)] 28 | [symbol? (define len (compose1 string-length symbol->string))] 29 | [path? (define len (compose1 string-length path->string))] 30 | [vector? (define len vector-length)] 31 | [hash? (define (len x) (length (hash-keys x)))] 32 | [(λ (x) (and (sequence? x) (not (integer? x)))) (define len (compose1 length sequence->list))])) 33 | 34 | 35 | (module+ test 36 | (require rackunit racket/set) 37 | (check-equal? (len '(1 2 3)) 3) 38 | (check-not-equal? (len '(1 2)) 3) ; len 2 39 | (check-equal? (len "foo") 3) 40 | (check-not-equal? (len "fo") 3) ; len 2 41 | (check-equal? (len 'foo) 3) 42 | (check-not-equal? (len 'fo) 3) ; len 2 43 | (check-equal? (len (list->vector '(1 2 3))) 3) 44 | (check-not-equal? (len (list->vector '(1 2))) 3) ; len 2 45 | (check-equal? (len (set 1 2 3)) 3) 46 | (check-not-equal? (len (set 1 2)) 3) ; len 2 47 | (check-equal? (len (make-hash '((a . 1) (b . 2) (c . 3)))) 3) 48 | (check-not-equal? (len (make-hash '((a . 1) (b . 2)))) 3)) ; len 2 -------------------------------------------------------------------------------- /sugar/private/syntax-utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base) 3 | syntax/define) 4 | (provide (except-out (all-defined-out) values->list)) 5 | 6 | (define-syntax-rule (require+provide/safe MODNAME ...) 7 | (begin 8 | (begin 9 | (require MODNAME) 10 | (provide (all-from-out MODNAME)) 11 | (module+ safe 12 | (require (submod MODNAME safe)) 13 | (provide (all-from-out (submod MODNAME safe))))) ...)) 14 | 15 | (define-syntax (values->list stx) 16 | (syntax-case stx () 17 | [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) 18 | 19 | ;; convert calling pattern to form (id contract body-exp) 20 | ;; hoist contract out of lambda-exp entirely 21 | (define (lambdafy-with-contract stx) 22 | (syntax-case stx () 23 | [(_ ID-EXP CONTRACT LAMBDA-EXP) ; matches exactly three args after `define` 24 | ;; `normalize-definition` can't handle the acceptable `define/contract` pattern of id, contract, lambda exp after the `define`. 25 | ;; so extract the contract, and then put id & lambda-exp back together, and let `normalize-definition` destructure as usual. 26 | (with-syntax ([(NEW-ID NEW-LAMBDA-EXP) 27 | (values->list (normalize-definition #'(_ ID-EXP LAMBDA-EXP) (datum->syntax stx 'λ) #t #t))]) 28 | #'(NEW-ID CONTRACT NEW-LAMBDA-EXP))] 29 | ;; matches two or more args (three-arg case handled above) 30 | [(_ ID-EXP . BODY) 31 | (with-syntax ([(NEW-ID (LAMBDA ARGS CONTRACT . NEW-BODY)) 32 | (values->list (normalize-definition stx (datum->syntax stx 'λ) #t #t))]) 33 | ;; because the macro provides the `lambda` below, it takes the local srcloc by default 34 | ;; so `syntax/loc` applies the original srcloc (associated with args and body-exp) 35 | #`(NEW-ID CONTRACT #,(syntax/loc #'ID-EXP (LAMBDA ARGS . NEW-BODY))))] 36 | ;; matches zero or one arguments 37 | [_ (raise-syntax-error 'define-macro "not enough arguments")])) 38 | 39 | (define (lambdafy stx) 40 | (with-syntax ([(ID LAMBDA-EXP) 41 | (values->list (normalize-definition stx (datum->syntax stx 'λ) #true #true))]) 42 | #'(ID LAMBDA-EXP))) -------------------------------------------------------------------------------- /sugar/scribblings/cache.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{Cache} 9 | @defmodule[#:multi (sugar/cache (submod sugar/cache safe))] 10 | 11 | If, like Ricky Bobby and me, you want to go fast, then try using more caches. They're wicked fast. 12 | 13 | @defproc[ 14 | (make-caching-proc 15 | [proc procedure?]) 16 | procedure?] 17 | Make a caching version of @racket[_proc]. This means a hash table will be attached to @racket[_proc], and result values will automatically be saved & retrieved. The arguments to the procedure are used as the hash key. 18 | 19 | In the example below, notice that both invocations of @racketfont{slow-op} take approximately the same time, whereas the second invocation of @racketfont{fast-op} gets its value from the cache, and is thus nearly instantaneous. 20 | 21 | @examples[#:eval my-eval 22 | (define (slow-op x) (for/sum ([i (in-range 100000000)]) i)) 23 | (time (slow-op 42)) 24 | (time (slow-op 42)) 25 | (define fast-op (make-caching-proc slow-op)) 26 | (time (fast-op 42)) 27 | (time (fast-op 42)) 28 | ] 29 | 30 | Keep in mind that the cache is only available to external callers of the resulting function. So if @racket[_proc] calls itself recursively, these calls are @italic{not} accelerated by the cache. If that's the behavior you need, use @racket[define/caching] to create a new recursive function. 31 | 32 | @defform[(define/caching (name arg ... . rest-arg) body ...)] 33 | Like @racket[define], but automatically uses @racket[make-caching-proc] to define a caching version of the function. If the function is recursive, the cache will be used for the recursive calls. 34 | 35 | In the example below, @racketfont{fib} is a recursive function. Notice that simply wrapping the function in @racket[make-caching-proc] doesn't work in this case, because @racketfont{fib}'s recursive calls to itself bypass the cache. But @racketfont{fib-fast} is rewritten to recur on the caching function, and the caching works as expected. 36 | 37 | @examples[#:eval my-eval 38 | (define (fib x) 39 | (if (< x 2) 1 (+ (fib (- x 1)) (fib (- x 2))))) 40 | (define fibber (make-caching-proc fib)) 41 | (define/caching (fib-fast x) 42 | (if (< x 2) 1 (+ (fib-fast (- x 1)) (fib-fast (- x 2))))) 43 | (time (fib 32)) 44 | (time (fibber 32)) 45 | (time (fib-fast 32)) 46 | ] -------------------------------------------------------------------------------- /sugar/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | racket/syntax 4 | syntax/strip-context 5 | "private/syntax-utils.rkt") 6 | racket/contract) 7 | 8 | (define-syntax (make-safe-module stx) 9 | (syntax-case stx () 10 | [(_ [ID CONTRACT]) 11 | ;; need to put `racket/contract` inside calling location's context 12 | (with-syntax ([RACKET/CONTRACT (datum->syntax #'ID 'racket/contract)]) 13 | #'(module+ safe 14 | (require RACKET/CONTRACT) 15 | (provide (contract-out [ID CONTRACT]))))] 16 | [(_ ID) 17 | #'(module+ safe 18 | (provide ID))])) 19 | 20 | (define-syntax (define+provide+safe stx) 21 | (with-syntax ([(ID CONTRACT LAMBDA-EXP) (lambdafy-with-contract stx)]) 22 | #'(begin 23 | (define ID LAMBDA-EXP) 24 | (provide+safe [ID CONTRACT])))) 25 | 26 | ;; for previously defined identifiers 27 | ;; takes args like (provide+safe [id contract]) or just (provide+safe id) 28 | ;; any number of args. 29 | (define-syntax-rule (provide+safe THING ...) 30 | (begin 31 | (provide+safe/once THING) ...)) 32 | 33 | ;; `provide+safe` might have interleaved ids or [id contract] args so handle them individually. 34 | (define-syntax (provide+safe/once stx) 35 | (with-syntax ([(ID MSM-ARG) (syntax-case stx () 36 | [(_ [ID contract]) 37 | #'(ID [ID contract])] 38 | [(_ id) 39 | #'(id id)])]) 40 | #'(begin 41 | (provide ID) 42 | (make-safe-module MSM-ARG)))) 43 | 44 | (define-syntax (define+provide/contract stx) 45 | (with-syntax* ([(ID CONTRACT LAMBDA-EXP) (lambdafy-with-contract stx)] 46 | [RACKET/CONTRACT (datum->syntax #'ID 'racket/contract)]) 47 | #'(begin 48 | (require RACKET/CONTRACT) 49 | (provide (contract-out [ID CONTRACT])) 50 | (define ID LAMBDA-EXP)))) 51 | 52 | (define-syntax (define/contract+provide stx) 53 | (with-syntax* ([(ID CONTRACT LAMBDA-EXP) (lambdafy-with-contract stx)] 54 | [RACKET/CONTRACT (datum->syntax #'ID 'racket/contract)]) 55 | #'(begin 56 | (require RACKET/CONTRACT) 57 | (provide ID) 58 | (define/contract ID CONTRACT LAMBDA-EXP)))) 59 | 60 | (define-syntax (define+provide stx) 61 | (with-syntax ([(ID LAMBDA-EXP) (lambdafy stx)]) 62 | #'(begin 63 | (provide ID) 64 | (define ID LAMBDA-EXP)))) 65 | 66 | (provide+safe make-safe-module 67 | define+provide+safe 68 | provide+safe 69 | define+provide/contract 70 | define/contract+provide 71 | define+provide) 72 | -------------------------------------------------------------------------------- /sugar/scribblings/file-extensions.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{File extensions} 9 | @defmodule[#:multi (sugar/file (submod sugar/file safe))] 10 | 11 | These functions don't access the filesystem. @bold{Warning}: these functions adopt the simplifying assumption that the paths are encoded as ASCII or UTF-8. A fully precise treatment of paths would need to handle them as byte strings. If you need that, see the functions in @racketmodname[racket/path]. This library will remain naive. 12 | 13 | Arguments that are @racket[pathish?] can take either a string or a path. For clarity below, I've used strings. 14 | 15 | @defproc[ 16 | (get-ext 17 | [file-path pathish?]) 18 | (or/c #f string?)] 19 | Return the last file extension of @racket[_file-path] as a string, or @racket[#f] if it has no extension. Omit the intervening @litchar{.} separator. 20 | 21 | @examples[#:eval my-eval 22 | (get-ext "foo.txt") 23 | (get-ext "/path/to/foo.txt") 24 | (get-ext "/path/to/foo.txt.bar") 25 | (get-ext "/path/to/file-without-extension") 26 | (get-ext "/path/to/directory/")] 27 | 28 | @defproc[ 29 | (has-ext? 30 | [file-path pathish?] 31 | [ext stringish?]) 32 | boolean?] 33 | Return @racket[#t] if the last file extension of @racket[_file-path] is @racket[_ext], otherwise @racket[#f]. Not sensitive to case. 34 | 35 | @examples[#:eval my-eval 36 | (has-ext? "foo.txt" "txt") 37 | (has-ext? "foo.txt" "TXT") 38 | (has-ext? "foo.txt" "jpg") 39 | (has-ext? "foo.jpg.txt" "jpg")] 40 | 41 | @defproc[ 42 | (remove-ext 43 | [file-path pathish?]) 44 | path?] 45 | Remove the last file extension of @racket[_file-path], and return the path that remains. If @racket[_file-path] has no extension, you just get the same @racket[_file-path]. Does not use the filesystem. 46 | 47 | @examples[#:eval my-eval 48 | (remove-ext "foo.txt") 49 | (remove-ext "/path/to/foo.txt") 50 | (remove-ext "/path/to/foo.txt.bar") 51 | (remove-ext (remove-ext "/path/to/foo.txt.bar"))] 52 | 53 | @defproc[ 54 | (remove-ext* 55 | [file-path pathish?]) 56 | path?] 57 | Like @racket[remove-ext], just more. Remove all file extensions from @racket[_file-path], and return the path that remains. If @racket[_file-path] has no extensions, you just get the same @racket[_file-path]. Does not use the filesystem. 58 | 59 | @examples[#:eval my-eval 60 | (remove-ext* "foo.txt") 61 | (remove-ext* "/path/to/foo.txt") 62 | (remove-ext* "/path/to/foo.txt.bar") 63 | (remove-ext* (remove-ext* "/path/to/foo.txt.bar"))] 64 | 65 | @defproc[ 66 | (add-ext 67 | [file-path pathish?] 68 | [ext stringish?]) 69 | path?] 70 | Return a new @racket[_file-path] with @racket[_ext] appended. Note that this does not replace an existing file extension. If that's what you want, then do @racket[(add-ext (remove-ext _file-path) _ext)]. 71 | 72 | @examples[#:eval my-eval 73 | (add-ext "foo" "txt") 74 | (add-ext "foo.txt" "jpg") 75 | (add-ext (remove-ext "foo.txt") "jpg")] 76 | -------------------------------------------------------------------------------- /sugar/scribblings/container.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{Container} 9 | @defmodule[#:multi (sugar/container (submod sugar/container safe))] 10 | 11 | Type-neutral functions for getting elements out of a container, or testing membership. 12 | 13 | 14 | @defproc[ 15 | (get 16 | [container (or/c list? vector? sequence? dict? string? symbol? path?)] 17 | [which any/c] 18 | [end_which (or/c (and/c integer? positive?) #f) #f]) 19 | any/c] 20 | For a @racket[_container] that's a @racket[dict?], retrieve the element associated with the key @racket[_which]. Raise an error if the key doesn't exist. 21 | 22 | @examples[#:eval my-eval 23 | (get (make-hash '((a . 1) (b . 2) (c . 3))) 'b) 24 | (get (make-hash '((a . 1) (b . 2) (c . 3))) 'z) 25 | ] 26 | 27 | For other @racket[_container] types — which are all sequence-like — retrieve the element located at @racket[_which]. Or if the optional @racket[_end_which] argument is provided, retrieve the elements from @racket[_which] to @racket[(sub1 _end_which)], inclusive (i.e., make a slice). Raise an error if @racket[_which] or @racket[_end_which] is out of bounds. 28 | 29 | @examples[#:eval my-eval 30 | (get '(0 1 2 3 4 5) 2) 31 | (get '(0 1 2 3 4 5) 2 4) 32 | (get '(0 1 2 3 4 5) 100) 33 | (get '(0 1 2 3 4 5) 2 100) 34 | (get (list->vector '(0 1 2 3 4 5)) 2) 35 | (get (list->vector '(0 1 2 3 4 5)) 2 4) 36 | (get "purple" 2) 37 | (get "purple" 2 4) 38 | (get 'purple 2) 39 | (get 'purple 2 4) 40 | ] 41 | 42 | When @racket[_container] is a path, it's treated as a list of path elements (created by @racket[explode-path]), not as a stringlike value. 43 | 44 | @examples[#:eval my-eval 45 | (get (string->path "/root/foo/bar/file.txt") 1) 46 | (get (string->path "/root/foo/bar/file.txt") 0 3) 47 | ] 48 | 49 | To slice to the end of @racket[_container], use @racket[(len _container)] as the value of @racket[_end_which]. 50 | 51 | @examples[#:eval my-eval 52 | (define xs '(0 1 2 3 4 5)) 53 | (get xs 2 (len xs)) 54 | (get (list->vector xs) 2 (len (list->vector xs))) 55 | (define color "purple") 56 | (get color 2 (len color)) 57 | ] 58 | 59 | 60 | @defproc[ 61 | (in? 62 | [item any/c] 63 | [container (or/c list? vector? sequence? set? dict? string? symbol? path?)]) 64 | boolean?] 65 | Return @racket[#t] if @racket[_item] is in @racket[_container], or @racket[#f] otherwise. 66 | 67 | @examples[#:eval my-eval 68 | (in? 2 '(0 1 2 3 4 5)) 69 | (in? 'a '(0 1 2 3 4 5)) 70 | (in? 2 (list->vector '(0 1 2 3 4 5))) 71 | (in? "pu" "purple") 72 | (in? "zig" "purple") 73 | (in? 'b (make-hash '((a . 1) (b . 2) (c . 3)))) 74 | (in? 'z (make-hash '((a . 1) (b . 2) (c . 3)))) 75 | ] 76 | 77 | As with @racket[get], when @racket[_container] is a path, it's treated as a list of exploded path elements, not as a stringlike value. 78 | 79 | @examples[#:eval my-eval 80 | (in? "foo" (string->path "/root/foo/bar/file.txt")) 81 | (in? "zam" (string->path "/root/foo/bar/file.txt")) 82 | ] 83 | 84 | -------------------------------------------------------------------------------- /sugar/unstable/js.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class (for-syntax racket/base racket/syntax) racket/dict) 3 | (provide (all-defined-out)) 4 | 5 | 6 | ;; js-style `push`, which appends to end of list 7 | (define-syntax-rule (push-end! ID THING) 8 | (set! ID (append ID (list THING)))) 9 | 10 | 11 | (define-syntax (increment! stx) 12 | (syntax-case stx () 13 | [(_ ID) #'(increment! ID 1)] 14 | [(_ ID EXPR) 15 | #'(begin (set! ID (+ ID EXPR)) ID)])) 16 | 17 | (module+ test 18 | (define xs '(1 2 3)) 19 | (push-end! xs 4) 20 | (check-equal? xs '(1 2 3 4))) 21 | 22 | (define-syntax-rule (+= ID THING) (begin (set! ID (+ ID THING)) ID)) 23 | (define-syntax-rule (++ ID) (+= ID 1)) 24 | (define-syntax-rule (-- ID) (+= ID -1)) 25 | (define-syntax-rule (-= ID THING) (+= ID (- THING))) 26 | 27 | 28 | ;; fancy number->string. bounds are checked, inexact integers are coerced. 29 | (define (number x #:round [round? #true]) 30 | (unless (and (number? x) (< -1e21 x 1e21)) 31 | (raise-argument-error 'number "valid number" x)) 32 | (let ([x (if round? (/ (round (* x 1e6)) 1e6) x)]) 33 | (number->string (if (integer? x) 34 | (inexact->exact x) 35 | x)))) 36 | 37 | (module+ test 38 | (check-equal? (number 4.5) "4.5") 39 | (check-equal? (number 4.0) "4") 40 | (check-equal? (number 4) "4") 41 | (check-equal? (number -4) "-4")) 42 | 43 | 44 | (define ·-helper 45 | (procedure-rename 46 | (λ (x . refs) 47 | (for/fold ([x x]) 48 | ([ref (in-list refs)] 49 | #:break (not x)) 50 | (cond 51 | ;; give `send` precedence (presence of method => wants runtime resolution of value) 52 | [(and (object? x) 53 | (memq ref (interface->method-names (object-interface x)))) (dynamic-send x ref)] 54 | ;; dict first, to catch objects that implement gen:dict 55 | [(dict? x) (dict-ref x ref #f)] 56 | [(object? x) (cond 57 | [(memq ref (field-names x)) (dynamic-get-field ref x)] 58 | [else #f])] 59 | [else (raise-argument-error '· "object or dict" (cons x refs))]))) '·)) 60 | 61 | (define-syntax-rule (· X REF ...) (·-helper X 'REF ...)) 62 | 63 | #;(module+ test 64 | (define c (class object% 65 | (super-new) 66 | (field [a 42]) 67 | (define/public (res) (hash 'res (hash 'b 43))))) 68 | (define co (make-object c)) 69 | (define h2 (hash 'a 42 'res co)) 70 | (check-equal? (· h2 a) 42) 71 | (check-equal? (· h2 b) 43) 72 | (check-equal? (· co a) 42) 73 | (check-equal? (· co b) 43)) 74 | 75 | (define-syntax-rule (·map REF XS) 76 | (for/list ([x (in-list XS)]) (· x REF))) 77 | 78 | (module+ test 79 | (require rackunit) 80 | (define C 81 | (class object% 82 | (super-new) 83 | (field [foo 'field]) 84 | (define/public (bar) 'method) 85 | (define/public (zam) (hasheq 'zoom 'hash)))) 86 | (define h (hasheq 'bam (new C) 'foo 'hashlet)) 87 | (define o (new C)) 88 | (check-equal? (· o foo) 'field) 89 | (check-equal? (· o bar) 'method) 90 | (check-equal? (· o zam zoom) 'hash) 91 | (check-equal? (· h bam foo) 'field) 92 | (check-equal? (· h bam bar) 'method) 93 | (check-equal? (· h bam zam zoom) 'hash) 94 | (check-equal? (·map foo (list o h)) '(field hashlet))) 95 | 96 | -------------------------------------------------------------------------------- /sugar/unstable/class.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base racket/syntax) racket/class) 3 | (provide (all-defined-out)) 4 | 5 | (define string% 6 | (class* object% (writable<%>) 7 | (super-new) 8 | (init-field [data #f]) 9 | (define (get-string) 10 | (with-handlers ([exn:fail:object? (λ (exn) data)]) 11 | (send this toString))) 12 | (define/public (custom-write port) (write (get-string) port)) 13 | (define/public (custom-display port) (display (get-string) port)))) 14 | 15 | (define mixin-tester% 16 | (class object% 17 | (super-new) 18 | (define/public (addContent val) (make-object string% val)))) 19 | 20 | (define-syntax (as-method stx) 21 | (syntax-case stx () 22 | [(_ ID) (with-syntax ([PRIVATE-ID (generate-temporary #'ID)]) 23 | #'(begin 24 | (public [PRIVATE-ID ID]) 25 | (define (PRIVATE-ID . args) (apply ID this args))))])) 26 | 27 | 28 | (define-syntax-rule (as-methods ID ...) 29 | (begin (as-method ID) ...)) 30 | 31 | 32 | (define-syntax (define-instance stx) 33 | (syntax-case stx () 34 | [(_ ID (MAKER BASE-CLASS . ARGS)) 35 | (with-syntax ([ID-CLASS (format-id stx "~a:~a" (syntax->datum #'BASE-CLASS) (syntax->datum #'ID))]) 36 | #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))]) 37 | (MAKER ID-CLASS . ARGS))))])) 38 | 39 | 40 | (define-syntax (define-class-predicates stx) 41 | (syntax-case stx () 42 | [(_ ID) 43 | (with-syntax ([+ID (format-id #'ID "+~a" (syntax->datum #'ID))] 44 | [ID? (format-id #'ID "~a?" (syntax->datum #'ID))]) 45 | #'(begin (define (ID? x) (is-a? x ID)) 46 | (define (+ID . args) (apply make-object ID args))))])) 47 | 48 | (define-syntax-rule (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) 49 | (begin 50 | (define ID (class* SUPERCLASS INTERFACES (init-field . INIT-ARGS) . BODY)) 51 | (define-class-predicates ID))) 52 | 53 | (define-syntax-rule (define-subclass/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) 54 | (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) (super-new) . BODY)) 55 | 56 | (define-syntax-rule (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) 57 | (define-subclass*/interfaces SUPERCLASS () (ID . INIT-ARGS) . BODY)) 58 | 59 | (define-syntax-rule (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) 60 | (define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) 61 | 62 | 63 | (define-syntax-rule (push-field! FIELD O EXPR) 64 | (set-field! FIELD O (cons EXPR (get-field FIELD O)))) 65 | 66 | 67 | (define-syntax-rule (push-end-field! FIELD O EXPR) 68 | (set-field! FIELD O (append (get-field FIELD O) (list EXPR)))) 69 | 70 | (define-syntax-rule (pop-field! FIELD O) 71 | (let ([xs (get-field FIELD O)]) 72 | (set-field! FIELD O (cdr xs)) 73 | (car xs))) 74 | 75 | (define-syntax (increment-field! stx) 76 | (syntax-case stx () 77 | [(_ FIELD O) #'(increment-field! FIELD O 1)] 78 | [(_ FIELD O EXPR) 79 | #'(begin (set-field! FIELD O (+ (get-field FIELD O) EXPR)) (get-field FIELD O))])) 80 | 81 | 82 | (define-syntax (getter-field/override stx) 83 | (syntax-case stx () 84 | [(_ [ID . EXPRS]) 85 | (syntax-property #'(getter-field [ID . EXPRS]) 'override #t)])) 86 | 87 | 88 | (define-syntax (getter-field stx) 89 | (syntax-case stx () 90 | [(_ [ID . EXPRS]) 91 | (with-syntax ([_ID (format-id #'ID "_~a" (syntax->datum #'ID))]) 92 | #`(begin 93 | (field [(ID _ID) . EXPRS]) 94 | (public (_ID ID)) 95 | (#,(if (syntax-property stx 'override) #'define/override #'define) (_ID) ID)))])) -------------------------------------------------------------------------------- /sugar/scribblings/debug.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar)) 7 | 8 | @title{Debug} 9 | @defmodule[#:multi (sugar/debug (submod sugar/debug safe))] 10 | 11 | Debugging utilities. 12 | 13 | @defform*[((report expr) (report expr maybe-name))] 14 | Print the name and value of @racket[_expr] to @racket[current-error-port], but also return the evaluated result of @racket[_expr] as usual. This lets you see the value of an expression or variable at runtime without disrupting any of the surrounding code. Optionally, you can use @racket[_maybe-name] to change the name shown in @racket[current-error-port]. 15 | 16 | For instance, suppose you wanted to see how @racket[first-condition?] was being evaluted in this expression: 17 | 18 | @racketblock[ 19 | (if (and (first-condition? x) (second-condition? x)) 20 | (one-thing) 21 | (other-thing))] 22 | 23 | You can wrap it in @racket[report] and find out: 24 | 25 | @racketblock[ 26 | (if (and (report (first-condition? x)) (second-condition? x)) 27 | (one-thing) 28 | (other-thing))] 29 | 30 | This code will run the same way as before. But when it reaches @racket[first-condition?], you willl see in @racket[current-error-port]: 31 | 32 | @racketerror{(first-condition? x) = #t} 33 | 34 | You can also add standalone calls to @racket[report] as a debugging aid at points where the return value will be irrelevant, for instance: 35 | 36 | @racketblock[ 37 | (report x x-before-function) 38 | (if (and (report (first-condition? x)) (second-condition? x)) 39 | (one-thing) 40 | (other-thing))] 41 | 42 | @racketerror{x-before-function = 42 43 | @(linebreak)(first-condition? x) = #t} 44 | 45 | But be careful — in the example below, the result of the @racket[if] expression will be skipped in favor of the last expression, which will be the value of @racket[_x]: 46 | 47 | @racketblock[ 48 | (if (and (report (first-condition? x)) (second-condition? x)) 49 | (one-thing) 50 | (other-thing)) 51 | (report x)] 52 | 53 | 54 | @defform*[((report/line expr) (report/line expr maybe-name))] 55 | Same as @racket[report], but also shows the line number of @racket[_expr]. 56 | 57 | @defform*[((report/file expr) (report/file expr maybe-name))] 58 | Same as @racket[report], but also shows the line number and source-file name of @racket[_expr]. 59 | 60 | @deftogether[( 61 | @defform[(report* expr ...)] 62 | @defform[(report*/line expr ...)] 63 | @defform[(report*/file expr ...)] 64 | )] 65 | Apply the relevant @racket[report] macro separately to each @racket[_expr] in the list. 66 | 67 | @defform[(repeat num expr ...)] 68 | Evaluate @racket[_expr] repeatedly — @racket[_num] times, in fact — and return the last value. 69 | 70 | @examples[#:eval my-eval 71 | (repeat 1000 72 | (for/sum ([i (in-range 1000)]) i)) 73 | ] 74 | 75 | 76 | @defform[(time-repeat num expr ...)] 77 | Shorthand for using @racket[time] with @racket[repeat]. Repeat the whole list of expressions, print the total time, and return the last value. 78 | 79 | @examples[#:eval my-eval 80 | (time-repeat 1000 81 | (for/product ([i (in-range 1000)]) i) 82 | (for/sum ([i (in-range 1000)]) i)) 83 | ] 84 | 85 | @defform[(time-repeat* num expr ...)] 86 | Apply @racket[time-repeat] to each @racket[_expr] individually. 87 | 88 | @examples[#:eval my-eval 89 | (time-repeat* 1000 90 | (for/product ([i (in-range 1000)]) i) 91 | (for/sum ([i (in-range 1000)]) i)) 92 | ] 93 | 94 | @defform[(compare expr id id-alt ...)] 95 | Evaluate @racket[_expr] first using @racket[_id], and then again substituting @racket[_id-alt] in place of @racket[_id], and then again for every other @racket[_id-alt] in the list. This is useful for comparing the performance of multiple versions of a function. 96 | 97 | @examples[#:eval my-eval 98 | (define (fib x) 99 | (if (< x 2) 1 (+ (fib (- x 1)) (fib (- x 2))))) 100 | (define/caching (fib-fast x) 101 | (if (< x 2) 1 (+ (fib-fast (- x 1)) (fib-fast (- x 2))))) 102 | (compare (time (fib 34)) fib fib-fast) 103 | ] 104 | 105 | -------------------------------------------------------------------------------- /sugar/file.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list 3 | racket/match 4 | (except-in racket/path filename-extension) 5 | "define.rkt" 6 | "coerce/base.rkt") 7 | 8 | ;; this is identical to `filename-extension` in `racket/path` 9 | ;; but will not treat hidden files as an extension (which is a bug) 10 | (define (filename-extension name) 11 | (match (file-name-from-path name) 12 | [(? path-for-some-system? filename) 13 | (=> resume) 14 | (match (regexp-match #rx#".[.]([^.]+)$" (path->bytes filename)) 15 | [(list _ second) second] 16 | [_ (resume)])] 17 | [_ #false])) 18 | 19 | (module+ test 20 | (require rackunit) 21 | (require (prefix-in rp: racket/path)) 22 | (check-equal? (rp:filename-extension (string->path ".foo")) #"foo") ; bad behavior 23 | (check-false (filename-extension (string->path ".foo")))) ; good behavior 24 | 25 | ;; does path have a certain extension, case-insensitively 26 | (define+provide+safe (has-ext? x ext) 27 | (pathish? stringish? . -> . boolean?) 28 | (unless (pathish? x) 29 | (raise-argument-error 'has-ext? "pathish?" x)) 30 | (unless (stringish? ext) 31 | (raise-argument-error 'has-ext? "stringish?" ext)) 32 | (define ext-of-path (filename-extension (->path x))) 33 | (and ext-of-path (string=? (string-downcase (bytes->string/utf-8 ext-of-path)) 34 | (string-downcase (->string ext))))) 35 | 36 | ;; get file extension as a string, or return #f 37 | ;; (consistent with filename-extension behavior) 38 | (define+provide+safe (get-ext x) 39 | (pathish? . -> . (or/c #f string?)) 40 | (unless (pathish? x) 41 | (raise-argument-error 'get-ext "pathish?" x)) 42 | (cond 43 | [(filename-extension (->path x)) => bytes->string/utf-8] 44 | [else #false])) 45 | 46 | ;; todo: add extensions 47 | (provide+safe binary-extensions) 48 | (define binary-extensions 49 | (map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe))) 50 | 51 | (define+provide+safe (has-binary-ext? x) 52 | (pathish? . -> . boolean?) 53 | (unless (pathish? x) 54 | (raise-argument-error 'has-binary-ext? "pathish?" x)) 55 | (for/or ([ext (in-list binary-extensions)] 56 | #:when (has-ext? (->path x) ext)) 57 | #true)) 58 | 59 | ;; put extension on path 60 | ;; use local contract here because this function is used within module 61 | (define+provide+safe (add-ext x ext) 62 | (stringish? stringish? . -> . pathish?) 63 | (unless (stringish? x) 64 | (raise-argument-error 'add-ext "stringish?" x)) 65 | (unless (stringish? ext) 66 | (raise-argument-error 'add-ext "stringish?" ext)) 67 | (->path (string-append (->string x) "." (->string ext)))) 68 | 69 | (define (starts-with? str starter) 70 | (define pat (regexp (format "^~a" (regexp-quote starter)))) 71 | (and (regexp-match pat str) #true)) 72 | 73 | (define (path-hidden? path) 74 | ((->string (file-name-from-path path)) . starts-with? . ".")) 75 | 76 | (define (change-hide-state new-hide-state path) 77 | (define reversed-path-elements (reverse (explode-path path))) 78 | (apply build-path (append (reverse (cdr reversed-path-elements)) 79 | (list (if (eq? new-hide-state 'hide) 80 | (format ".~a" (->string (car reversed-path-elements))) 81 | (regexp-replace #rx"^." (->string (car reversed-path-elements)) "")))))) 82 | 83 | ;; take one extension off path 84 | (define+provide+safe (remove-ext x) 85 | (pathish? . -> . path?) 86 | ;; `path-replace-suffix` incorrectly thinks any leading dot counts as a file extension 87 | ;; when it might be a hidden path. 88 | ;; so handle hidden paths specially. 89 | ;; this is fixed in later Racket versions with `path-replace-extension` 90 | (match (->path x) 91 | [(? path-hidden? path) (change-hide-state 'hide (path-replace-suffix (change-hide-state 'unhide path) ""))] 92 | [path (path-replace-suffix path "")])) 93 | 94 | ;; take all extensions off path 95 | (define+provide+safe (remove-ext* x) 96 | (pathish? . -> . path?) 97 | (let loop ([path (->path x)]) 98 | (match (remove-ext path) 99 | [(== path) path] 100 | [path-reduced (loop path-reduced)]))) -------------------------------------------------------------------------------- /sugar/unstable/container.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../define.rkt" "../coerce.rkt" "len.rkt" racket/list racket/set racket/sequence racket/stream racket/dict) 3 | 4 | (define (sliceable-container? x) 5 | (ormap (λ(proc) (proc x)) (list list? string? symbol? vector? path? (λ(i) (and (not (dict? i)) (sequence? i)))))) 6 | 7 | (define (gettable-container? x) 8 | (ormap (λ(proc) (proc x)) (list sliceable-container? dict?))) 9 | 10 | 11 | (define+provide+safe (get container start [end #f]) 12 | ((gettable-container? any/c) ((or/c (and/c integer? positive?) #f)) . ->* . any) 13 | 14 | (define result 15 | ;; use handler to capture error & print localized error message 16 | (with-handlers ([exn:fail? (λ(exn) (error (format "get: couldn't retrieve ~a from ~a" (if end (format "items ~a through ~a" start end) (format "item ~a" start)) container)))]) 17 | (let ([end (if (and (equal? end #f) (sliceable-container? container)) (add1 start) end)]) 18 | (cond 19 | [(list? container) (for/list ([i (in-range start end)]) (list-ref container i))] 20 | [(vector? container) (for/vector ([i (in-range start end)]) (vector-ref container i))] 21 | [(string? container) (substring container start end)] 22 | [(symbol? container) (->symbol (get (->string container) start end))] 23 | [(path? container) (get (explode-path container) start end)] 24 | [(dict? container) (dict-ref container start)] 25 | [(sequence? container) (get (->list container) start end)] 26 | [else (error)])))) 27 | 28 | ;; don't return single-item results inside a list 29 | ;; check for integer because integers don't have length 30 | (if (and (not (integer? result)) (= (len result) 1) (sliceable-container? container)) 31 | (car (->list result)) 32 | result)) 33 | 34 | (define (listlike-container? container) 35 | (ormap (λ(pred) (pred container)) (list vector? set? sequence?))) 36 | 37 | (define+provide+safe (in? item container) 38 | (any/c any/c . -> . boolean?) 39 | (->boolean (cond 40 | [(list? container) (member item container)] 41 | [(dict? container) (dict-has-key? container item)] 42 | [(path? container) (in? (->path item) (explode-path container))] 43 | [(stringish? container) (regexp-match (->string item) (->string container))] 44 | ;; location relevant because dicts and strings are also listlike (= sequences) 45 | [(listlike-container? container) (in? item (->list container))] 46 | [else #f]))) 47 | 48 | 49 | 50 | (module+ test 51 | (require rackunit) 52 | (check-equal? (get '(0 1 2 3 4 5) 2) 2) 53 | (check-exn exn:fail? (λ() (get '(0 1 2 3 4 5) 100))) ; index too big 54 | (check-equal? (get `(0 1 ,(list 2) 3 4 5) 2) (list 2)) 55 | (check-equal? (get '(0 1 2 3 4 5) 0 2) '(0 1)) 56 | (check-equal? (get (list->vector '(0 1 2 3 4 5)) 2) 2) 57 | (check-equal? (get (list->vector'(0 1 2 3 4 5)) 0 2) (list->vector '(0 1))) 58 | (check-equal? (get "purple" 2) "r") 59 | (check-equal? (get "purple" 0 2) "pu") 60 | (check-equal? (get 'purple 2) 'r) 61 | (check-equal? (get 'purple 0 2) 'pu) 62 | (check-equal? (get (string->path "/root/foo/bar/file.txt") 2) (string->path "foo")) 63 | (check-equal? (get (string->path "/root/foo/bar/file.txt") 0 2) (list (string->path "/") (string->path "root"))) 64 | (check-equal? (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'a) (list 1)) 65 | (check-exn exn:fail? (λ() (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'z))) ; nonexistent key 66 | 67 | (check-equal? (get (string->path "/root/foo/bar/file.txt") 1) (string->path "root")) 68 | (check-equal? (get (string->path "/root/foo/bar/file.txt") 0 3) 69 | (map string->path '("/" "root" "foo"))) 70 | 71 | (check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'b) 2) 72 | 73 | (check-true (2 . in? . '(1 2 3))) 74 | (check-false (4 . in? . '(1 2 3))) 75 | (check-true (2 . in? . (list->vector '(1 2 3)))) 76 | (check-false (4 . in? . (list->vector '(1 2 3)))) 77 | (check-true ('a . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) 78 | (check-false ('x . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) 79 | (check-true ("o" . in? . "foobar")) 80 | (check-false ("z" . in? . "foobar")) 81 | (check-true ('o . in? . 'foobar)) 82 | (check-false ('z . in? . 'foobar)) 83 | (check-true ("F" . in? . #\F)) 84 | 85 | (check-true (in? "foo" (string->path "/root/foo/bar/file.txt"))) 86 | (check-false (in? "zam" (string->path "/root/foo/bar/file.txt")))) 87 | -------------------------------------------------------------------------------- /sugar/coerce/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax 3 | racket/base 4 | racket/syntax) 5 | racket/stream 6 | racket/generic 7 | net/url 8 | racket/sequence 9 | "../unstable/len.rkt" 10 | "../define.rkt") 11 | 12 | (module+ safe (require racket/contract)) 13 | 14 | (define-syntax-rule (make-coercion-error-handler func funcish val) 15 | (λ (exn) (raise-argument-error 'func (symbol->string 'funcish) val))) 16 | 17 | (define (disjoin . preds) (λ (x) (ormap (λ (pred) (pred x)) preds))) 18 | (define (conjoin . preds) (λ (x) (andmap (λ (pred) (pred x)) preds))) 19 | 20 | (define-generics+provide+safe stringish 21 | (any/c . -> . string?) 22 | (->string stringish) 23 | #:fast-defaults 24 | ([string? (define ->string values)] 25 | [(disjoin null? void?) (define (->string x) "")] 26 | [symbol? (define ->string symbol->string)] 27 | [number? (define ->string number->string)] 28 | [path? (define ->string path->string)] 29 | [(disjoin char? bytes?) (define (->string x) (format "~a" x))] 30 | [url? (define ->string url->string)])) 31 | 32 | 33 | (define (real->int x) (inexact->exact (floor x))) 34 | (define (string->int x) (let ([strnum (string->number x)]) 35 | (unless (real? strnum) 36 | (raise-argument-error '->int "eligible string" x)) 37 | (real->int strnum))) 38 | 39 | (define-generics+provide+safe intish 40 | (any/c . -> . integer?) 41 | (->int intish) 42 | #:fast-defaults 43 | ([(disjoin integer? real?) (define ->int real->int)] 44 | [complex? (define ->int (compose1 real->int real-part))] 45 | [string? (define ->int string->int)] 46 | [(disjoin symbol? path? bytes?) (define ->int (compose1 string->int ->string))] 47 | [char? (define ->int char->integer)] 48 | [lengthable? (define (->int x) 49 | (with-handlers ([exn:fail? (make-coercion-error-handler ->int intish? x)]) 50 | (len x)))])) 51 | 52 | 53 | (define-generics+provide+safe symbolish 54 | (any/c . -> . symbol?) 55 | (->symbol symbolish) 56 | #:fast-defaults 57 | ([symbol? (define ->symbol values)] 58 | [stringish? (define (->symbol x) 59 | (with-handlers ([exn:fail? (make-coercion-error-handler ->symbol symbolish? x)]) 60 | (string->symbol (->string x))))])) 61 | 62 | 63 | (define-generics+provide+safe pathish 64 | (any/c . -> . path?) 65 | (->path pathish) 66 | #:fast-defaults 67 | ([path? (define ->path values)] 68 | [stringish? (define (->path x) 69 | (with-handlers ([exn:fail? (make-coercion-error-handler ->path pathish? x)]) 70 | (if (url? x) 71 | (url->path x) 72 | (string->path (->string x)))))])) 73 | 74 | (define-generics+provide+safe urlish 75 | (any/c . -> . url?) 76 | (->url urlish) 77 | #:fast-defaults 78 | ([url? (define ->url values)] 79 | [stringish? (define (->url x) 80 | (with-handlers ([exn:fail? (make-coercion-error-handler ->url urlish? x)]) 81 | (string->url (->string x))))])) 82 | 83 | 84 | (define-generics+provide+safe complete-pathish 85 | (any/c . -> . complete-path?) 86 | (->complete-path complete-pathish) 87 | #:fast-defaults 88 | ([(conjoin path? complete-path?) 89 | ;; caution: plain `complete-path?` returns #t for path strings, 90 | ;; so also check `path?` 91 | (define ->complete-path values)] 92 | [stringish? (define (->complete-path x) 93 | (with-handlers ([exn:fail? (make-coercion-error-handler ->complete-path complete-pathish? x)]) 94 | (path->complete-path (->path x))))])) 95 | 96 | 97 | (define-generics+provide+safe listish 98 | (any/c . -> . list?) 99 | (->list listish) 100 | #:fast-defaults 101 | ([list? (define ->list values)] 102 | [string? (define ->list list)] 103 | [vector? (define ->list vector->list)] 104 | [hash? (define ->list hash->list)] 105 | [integer? (define ->list list)] 106 | [sequence? (define ->list sequence->list)] 107 | [stream? (define ->list stream->list)] 108 | [(λ (x) #t) (define ->list list)])) 109 | 110 | 111 | (define-generics+provide+safe vectorish 112 | (any/c . -> . vector?) 113 | (->vector vectorish) 114 | #:fast-defaults 115 | ([vector? (define ->vector values)] 116 | [listish? (define (->vector x) 117 | (with-handlers ([exn:fail? (make-coercion-error-handler ->vector vectorish? x)]) 118 | (list->vector (->list x))))])) 119 | 120 | 121 | (define+provide+safe (->boolean x) 122 | (any/c . -> . boolean?) 123 | (and x #t)) -------------------------------------------------------------------------------- /sugar/scribblings/coerce.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar racket/contract)) 7 | 8 | @title{Coercion} 9 | @defmodule[#:multi (sugar/coerce (submod sugar/coerce safe))] 10 | 11 | Functions that coerce the datatype of a value to another type. Racket already has type-specific conversion functions. But if you're handling values of indeterminate type — as sometimes happens in an untyped language — then handling the possible cases individually gets to be a drag. 12 | 13 | @section{Values} 14 | 15 | @defproc[ 16 | (->int 17 | [v any/c]) 18 | integer?] 19 | Convert @racket[_v] to an integer in the least surprising way, or raise an error if no conversion is possible. 20 | 21 | Numbers are rounded down to the nearest integer. 22 | 23 | @examples[#:eval my-eval 24 | (->int 3) 25 | (->int 3.5) 26 | (->int -2.5) 27 | (->int (+ 3 (/ 1 2)))] 28 | 29 | Stringlike values — paths, symbols, and strings — are converted to numbers and rounded down. 30 | 31 | @examples[#:eval my-eval 32 | (->int "3.5") 33 | (->int '3.5) 34 | (->int (string->path "3.5"))] 35 | 36 | Characters are directly converted to integers. 37 | 38 | @examples[#:eval my-eval 39 | (->int #\A) 40 | (->int #\◊)] 41 | 42 | Lists, vectors, and other multi-value datatypes return their length (using @racket[len]). 43 | 44 | @examples[#:eval my-eval 45 | (->int (list 5 6 7)) 46 | (->int (hash 'a 1 'b 2 'c 3))] 47 | 48 | The function will raise an error if no sensible conversion is possible. 49 | @examples[#:eval my-eval 50 | (->int #t) 51 | ] 52 | 53 | @defproc[ 54 | (->string 55 | [v any/c]) 56 | string?] 57 | Return the most natural string representation of @racket[_v], or raise an error if none exists. 58 | 59 | @examples[#:eval my-eval 60 | (->string "string") 61 | (->string 'symbol) 62 | (->string 98.6) 63 | (->string (string->path "stdio.h")) 64 | (->string #\u0041) 65 | (->string #t) 66 | ] 67 | 68 | @defproc[ 69 | (->symbol 70 | [v any/c]) 71 | symbol?] 72 | Same as @racket[->string], but return a symbol rather than a string. 73 | 74 | @examples[#:eval my-eval 75 | (->symbol "string") 76 | (->symbol 'symbol) 77 | (->symbol 98.6) 78 | (->symbol (string->path "stdio.h")) 79 | (->symbol #\u0041) 80 | (->symbol #t) 81 | ] 82 | 83 | @deftogether[( 84 | @defproc[ 85 | (->path 86 | [v any/c]) 87 | path?] 88 | 89 | @defproc[ 90 | (->complete-path 91 | [v any/c]) 92 | complete-path?] 93 | )] 94 | Same as @racket[->string], but return a path (or complete path) rather than a string. 95 | 96 | @examples[#:eval my-eval 97 | (->path "string") 98 | (->path 'symbol) 99 | (->complete-path 98.6) 100 | (->complete-path (string->path "stdio.h")) 101 | (->complete-path #\u0041) 102 | (->complete-path #t) 103 | ] 104 | 105 | 106 | @defproc[ 107 | (->list 108 | [v any/c]) 109 | list?] 110 | If @racket[_v] is a listlike data type — a vector, set, stream, sequence, or list — convert it to a list. A hash or dictionary becomes a list using @racket[dict->list]. If @racket[_v] is an atomic value, turn it into a single-member list. 111 | 112 | Note that a string is treated as an atomic value rather than decomposed with @racket[string->list]. This is done so the function handles strings the same way as symbols and paths. 113 | 114 | @examples[#:eval my-eval 115 | (->list '(a b c)) 116 | (->list (list->vector '(a b c))) 117 | (->list (make-hash '((k . v) (k2 . v2)))) 118 | (->list "string") 119 | (->list 'symbol) 120 | (->list (string->path "path")) 121 | (->list +) 122 | ] 123 | 124 | @defproc[ 125 | (->vector 126 | [v any/c]) 127 | vector?] 128 | Same as @racket[->list], but returns a vector rather than a list. 129 | 130 | @examples[#:eval my-eval 131 | (->vector '(a b c)) 132 | (->vector (list->vector '(a b c))) 133 | (->vector (make-hash '((k . v) (k2 . v2)))) 134 | (->vector "string") 135 | (->vector 'symbol) 136 | (->vector (string->path "path")) 137 | (->vector +) 138 | ] 139 | 140 | @defproc[ 141 | (->boolean 142 | [v any/c]) 143 | boolean?] 144 | Return @racket[#t] for all @racket[_v] except @racket[#f], which remains @racket[#f]. 145 | 146 | @examples[#:eval my-eval 147 | (->boolean "string") 148 | (->boolean 'symbol) 149 | (->boolean +) 150 | (->boolean '(l i s t)) 151 | (->boolean #f) 152 | ] 153 | 154 | 155 | @deftogether[( 156 | @defproc[(intish? [v any/c]) boolean?] 157 | @defproc[(stringish? [v any/c]) boolean?] 158 | @defproc[(symbolish? [v any/c]) boolean?] 159 | @defproc[(pathish? [v any/c]) boolean?] 160 | @defproc[(complete-pathish? [v any/c]) boolean?] 161 | @defproc[(listish? [v any/c]) boolean?] 162 | @defproc[(vectorish? [v any/c]) boolean?] 163 | )] 164 | Predicates that report whether @racket[_v] can be coerced to the specified type. 165 | 166 | @examples[#:eval my-eval 167 | (map intish? (list 3 3.5 #\A "A" + #t)) 168 | (map stringish? (list 3 3.5 #\A "A" + #t)) 169 | (map symbolish? (list 3 3.5 #\A "A" + #t)) 170 | (map pathish? (list 3 3.5 #\A "A" + #t)) 171 | (map complete-pathish? (list 3 3.5 #\A "A" + #t)) 172 | (map listish? (list 3 3.5 #\A "A" + #t)) 173 | (map vectorish? (list 3 3.5 #\A "A" + #t)) 174 | ] 175 | 176 | 177 | 178 | @section{Coercion contracts} 179 | 180 | @deftogether[( 181 | @defproc[(coerce/int? [v any/c]) integer?] 182 | @defproc[(coerce/string? [v any/c]) string?] 183 | @defproc[(coerce/symbol? [v any/c]) symbol?] 184 | @defproc[(coerce/path? [v any/c]) path?] 185 | @defproc[(coerce/boolean? [v any/c]) boolean?] 186 | @defproc[(coerce/list? [v any/c]) list?] 187 | )] 188 | If @racket[_v] can be coerced to the specified type, change it to that type, then return it. If not, raise the usual contract error. These contracts can be used with input or output values. 189 | 190 | @examples[#:eval my-eval 191 | (define/contract (add-ints x y) 192 | (coerce/int? coerce/int? . -> . any/c) 193 | (+ x y)) 194 | (code:comment @#,t{Input arguments will be coerced to integers, then added}) 195 | (add-ints 1.6 3.8) 196 | (define/contract (int-sum x y) 197 | (any/c any/c . -> . coerce/int?) 198 | (+ x y)) 199 | (code:comment @#,t{Input arguments will be added, and the result coerced to an integer}) 200 | (int-sum 1.6 3.8) 201 | ] 202 | 203 | 204 | Please note: this is not an officially sanctioned way to use Racket's contract system, because contracts aren't supposed to mutate their values (see @racket[make-contract]). 205 | 206 | But coercion contracts can be useful in two situations: 207 | 208 | @itemlist[ 209 | 210 | @item{You want to be liberal about input types, but don't want to deal with the housekeeping and manual conversions between types.} 211 | 212 | @item{Your contract involves an expensive operation that you'd rather avoid performing twice.} 213 | 214 | 215 | ] 216 | 217 | 218 | 219 | -------------------------------------------------------------------------------- /sugar/unstable/include.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | syntax/path-spec 4 | racket/private/increader 5 | compiler/cm-accomplice 6 | racket/match racket/function) 7 | "../define.rkt") 8 | 9 | (provide+safe include-without-lang-line) 10 | 11 | (define-syntax (do-include stx) 12 | (syntax-case stx () 13 | [(_ orig-stx ctx loc fn reader) 14 | ;; Parse the file name 15 | (let ([orig-c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx))] 16 | [ctx (syntax ctx)] 17 | [loc (syntax loc)] 18 | [reader (syntax reader)] 19 | [orig-stx (syntax orig-stx)] 20 | [rkt->ss (lambda (p) 21 | (let ([b (path->bytes p)]) 22 | (if (regexp-match? #rx#"[.]rkt$" b) 23 | (path-replace-suffix p #".ss") 24 | p)))]) 25 | 26 | (let ([c-file (if (file-exists? orig-c-file) 27 | orig-c-file 28 | (let ([p2 (rkt->ss orig-c-file)]) 29 | (if (file-exists? p2) 30 | p2 31 | orig-c-file)))]) 32 | 33 | (register-external-file c-file) 34 | 35 | (let ([read-syntax (if (syntax-e reader) 36 | (reader-val 37 | (let loop ([e (syntax->datum 38 | (local-expand reader 'expression null))]) 39 | (cond 40 | [(reader? e) e] 41 | [(pair? e) (or (loop (car e)) 42 | (loop (cdr e)))] 43 | [else #f]))) 44 | (lambda (src in) 45 | (parameterize ([read-accept-reader #t]) 46 | (read-syntax src in))))]) 47 | (unless (and (procedure? read-syntax) 48 | (procedure-arity-includes? read-syntax 2)) 49 | (raise-syntax-error 50 | #f 51 | "reader is not a procedure of two arguments" 52 | orig-stx)) 53 | 54 | ;; Open the included file 55 | (let ([p (with-handlers ([exn:fail? 56 | (lambda (exn) 57 | (raise-syntax-error 58 | #f 59 | (format 60 | "can't open include file (~a)" 61 | (if (exn? exn) 62 | (exn-message exn) 63 | exn)) 64 | orig-stx 65 | c-file))]) 66 | (open-input-file c-file))]) 67 | (port-count-lines! p) 68 | ;; Read expressions from file 69 | (let ([content 70 | (let loop () 71 | (let ([r (with-handlers ([exn:fail? 72 | (lambda (exn) 73 | (close-input-port p) 74 | (raise-syntax-error 75 | #f 76 | (format 77 | "read error (~a)" 78 | (if (exn? exn) 79 | (exn-message exn) 80 | exn)) 81 | orig-stx))]) 82 | (read-syntax c-file p))]) 83 | (if (eof-object? r) 84 | null 85 | (cons r (loop)))))]) 86 | 87 | ;; Here's where we'll separate the content of the file from the #lang line. 88 | ;; the resulting material will be stored in 'content-guts'. 89 | ;; 'content' is a list of syntax objects from the source file. 90 | ;; Each object corresponds to a top-level expression in the file, converted to syntax. 91 | ;; If the file has a #lang line, there's only one expression (because the #lang expands to a single `module` form). 92 | ;; If it doesn't, then there are an indefinite number of expressions. 93 | ;; So we'll handle both types with a match. 94 | (define content-guts 95 | (cond 96 | [(not (null? content)) 97 | (define content-syntax (car content)) ; save the first syntax object (its context will be needed momentarily) 98 | ;; peel the wrapper off the file. it will come in like so 99 | ;; (module foo whatever/lang (#%module-begin expr ...)) 100 | ;; the guts are the (expr ...). To get them, we want the cdr of the fourth element. 101 | (define fourth cadddr) ; we don't have `fourth` in the syntax environment. 102 | ;; get the guts and package them back into a syntax object using the saved content-syntax as context. 103 | (define guts-data (match (map syntax->datum content) 104 | [(list (list 'module modname lang (list '#%module-begin exprs ...))) exprs] 105 | [(list exprs ...) exprs])) 106 | (map (curry datum->syntax content-syntax) guts-data)] 107 | [else null])) 108 | (close-input-port p) 109 | ;; Preserve src info for content, but set its 110 | ;; lexical context to be that of the include expression 111 | (let ([lexed-content 112 | (let loop ([content content-guts]) ;; start with the new content-guts 113 | (cond 114 | [(pair? content) 115 | (cons (loop (car content)) 116 | (loop (cdr content)))] 117 | [(null? content) null] 118 | [else 119 | (let ([v (syntax-e content)]) 120 | (datum->syntax 121 | ctx 122 | (cond 123 | [(pair? v) 124 | (loop v)] 125 | [(vector? v) 126 | (list->vector (loop (vector->list v)))] 127 | [(box? v) 128 | (box (loop (unbox v)))] 129 | [else 130 | v]) 131 | content 132 | content))]))]) 133 | * 134 | (datum->syntax 135 | (quote-syntax here) 136 | `(begin ,@lexed-content) 137 | orig-stx)))))))])) 138 | 139 | (define-syntax (include-without-lang-line stx) 140 | (syntax-case stx () 141 | [(_ fn) 142 | (with-syntax ([_stx stx]) 143 | (syntax/loc stx (do-include _stx _stx _stx fn #f)))])) 144 | -------------------------------------------------------------------------------- /sugar/debug.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/string 3 | (for-syntax racket/base) 4 | "define.rkt") 5 | 6 | (provide+safe report report/time time-name 7 | report/line report/file 8 | report* report*/line report*/file 9 | report-apply repeat time-repeat time-repeat* time-name time-named time-avg compare) 10 | 11 | (define (stringify-results expr-results) 12 | (format (if (= 1 (length expr-results)) 13 | "~a" 14 | "(values ~a)") (string-join (for/list ([r (in-list expr-results)]) 15 | (format "~v" r)) " "))) 16 | 17 | (define-syntax (report stx) 18 | (syntax-case stx () 19 | [(MACRO EXPR) #'(MACRO EXPR EXPR)] 20 | [(_ EXPR NAME) 21 | #'(let ([expr-results (call-with-values (λ () EXPR) list)]) 22 | (eprintf "~a = ~a\n" 'NAME (stringify-results expr-results)) 23 | (apply values expr-results))])) 24 | 25 | (define-syntax (report/time stx) 26 | (syntax-case stx () 27 | [(MACRO EXPR) #'(MACRO EXPR EXPR)] 28 | [(_ EXPR NAME) 29 | #'(let* ([op (open-output-string)] 30 | [expr-results (parameterize ([current-output-port op]) 31 | (time (call-with-values (λ () EXPR) list)))]) 32 | (eprintf "~a = ~a [~a]\n" 'NAME (stringify-results expr-results) (string-trim (get-output-string op))) 33 | (apply values expr-results))])) 34 | 35 | (define-syntax (report/line stx) 36 | (syntax-case stx () 37 | [(MACRO EXPR) #'(MACRO EXPR EXPR)] 38 | [(_ EXPR NAME) 39 | #`(let ([expr-results (call-with-values (λ () EXPR) list)]) 40 | (eprintf "~a = ~a on line ~a\n" 'NAME (stringify-results expr-results) #,(syntax-line #'EXPR)) 41 | (apply values expr-results))])) 42 | 43 | (define-syntax (report/file stx) 44 | (syntax-case stx () 45 | [(MACRO EXPR) #'(MACRO EXPR EXPR)] 46 | [(_ EXPR NAME) 47 | #`(let ([expr-results (call-with-values (λ () EXPR) list)]) 48 | (eprintf "~a = ~a on line ~a in \"~a\"\n" 'NAME (stringify-results expr-results) 49 | #,(syntax-line #'EXPR) 50 | '#,(syntax-source #'EXPR)) 51 | (apply values expr-results))])) 52 | 53 | (define-syntax-rule (define-multi-version MULTI-NAME NAME) 54 | (define-syntax-rule (MULTI-NAME x (... ...)) 55 | (begin (NAME x) (... ...)))) 56 | 57 | (define-multi-version report* report) 58 | (define-multi-version report*/line report/line) 59 | (define-multi-version report*/file report/file) 60 | 61 | (define-syntax (report-apply stx) 62 | (syntax-case stx () 63 | [(_ PROC EXPR) 64 | #'(let ([lst EXPR]) 65 | (report (apply PROC lst) (apply PROC EXPR)) 66 | lst)] 67 | [(_ PROC EXPR #:line) 68 | #'(let ([lst EXPR]) 69 | (report (apply PROC lst) (apply PROC EXPR) #:line) 70 | lst)])) 71 | 72 | (define-syntax-rule (repeat NUM EXPR ...) 73 | (for/last ([i (in-range NUM)]) 74 | EXPR ...)) 75 | 76 | (define-syntax-rule (time-repeat NUM EXPR ...) 77 | (time (repeat NUM EXPR ...))) 78 | 79 | (define (parse-time-str str) 80 | (for/list ([num (in-port read (open-input-string str))] 81 | #:when (number? num)) 82 | num)) 83 | 84 | (define-syntax-rule (time-avg NUM EXPR ...) 85 | (let ([n NUM]) 86 | (define-values (strs results) 87 | (for/lists (strs results) 88 | ([i n]) 89 | (let* ([op (open-output-string)] 90 | [expr-results (parameterize ([current-output-port op]) 91 | (time (call-with-values (λ () EXPR ...) values)))]) 92 | (values (get-output-string op) expr-results)))) 93 | (displayln (apply format "~a: cpu time: ~a real time: ~a gc time: ~a (avg of ~a)" 94 | (append 95 | (list (car '(EXPR ...))) 96 | (for/list ([vals (apply map list (map parse-time-str strs))]) 97 | (floor (/ (apply + vals) n))) 98 | (list n)))) 99 | (car (reverse results)))) 100 | 101 | (define-syntax (time-repeat* stx) 102 | (syntax-case stx () 103 | [(_ NUM EXPR ...) 104 | #'(let ([n NUM]) 105 | (values (time-repeat n EXPR) ...))])) 106 | 107 | (define-syntax (time-name stx) 108 | (syntax-case stx () 109 | [(_ NAME EXPR ...) 110 | #'(let* ([op (open-output-string)] 111 | [expr-results (parameterize ([current-output-port op]) 112 | (time (call-with-values (λ () EXPR ...) values)))]) 113 | (display (format "~a: ~a" 'NAME (get-output-string op))) 114 | expr-results)])) 115 | 116 | (define-syntax (time-named stx) 117 | (syntax-case stx () 118 | [(_ EXPR ...) 119 | #'(let* ([op (open-output-string)] 120 | [expr-results (parameterize ([current-output-port op]) 121 | (time (call-with-values (λ () EXPR ...) values)))]) 122 | (display (format "~a: ~a" (car '(EXPR ...)) (get-output-string op))) 123 | expr-results)])) 124 | 125 | (define-syntax (compare stx) 126 | (syntax-case stx () 127 | [(_ EXPR ID ID-ALT ...) 128 | #'(values EXPR (let ([ID ID-ALT]) EXPR) ...)])) 129 | 130 | (module reader racket/base 131 | (require syntax/module-reader racket/syntax version/utils) 132 | (provide (rename-out [debug-read read] 133 | [debug-read-syntax read-syntax] 134 | [debug-get-info get-info])) 135 | 136 | (define current-metalang-scope-flipper (make-parameter values)) 137 | 138 | (define (wrap-reader reader) 139 | (λ args 140 | (parameterize ([current-readtable (make-debug-readtable (current-readtable))] 141 | [current-metalang-scope-flipper (make-syntax-introducer)]) 142 | (define stx (apply reader args)) 143 | (define proc (if (and (syntax? stx) (version<=? "6.2.900.4" (version))) 144 | (current-metalang-scope-flipper) 145 | values)) 146 | (proc stx)))) 147 | 148 | (define-values (debug-read debug-read-syntax debug-get-info) 149 | (make-meta-reader 150 | 'sugar/debug 151 | "language path" 152 | (λ (bstr) ; copy of `lang-reader-module-paths`, only available since 6.7 153 | (let* ([str (bytes->string/latin-1 bstr)] 154 | [sym (string->symbol str)]) 155 | (and (module-path? sym) 156 | (vector 157 | ;; try submod first: 158 | `(submod ,sym reader) 159 | ;; fall back to /lang/reader: 160 | (string->symbol (string-append str "/lang/reader")))))) 161 | wrap-reader 162 | wrap-reader 163 | (λ (proc) 164 | (λ (key defval) 165 | (case key 166 | [else (if proc (proc key defval) defval)]))))) 167 | 168 | (define report-char #\R) 169 | 170 | (define (make-debug-readtable [rt (current-readtable)]) 171 | (make-readtable rt report-char 'dispatch-macro report-proc)) 172 | 173 | (define (another-report-char? ip) (and (char=? (peek-char ip) report-char) (read-char ip))) 174 | 175 | (define (report-proc trigger-char ip src ln col pos) 176 | (define flip-metalang-scope (current-metalang-scope-flipper)) 177 | (flip-metalang-scope (with-syntax ([REPORT-ID (cond 178 | [(not (another-report-char? ip)) 'report] ; #R... 179 | [(not (another-report-char? ip)) 'report/line] ; #RR... 180 | [else 'report/file])] ; #RRR... 181 | [STX (flip-metalang-scope (read-syntax/recursive src ip))]) 182 | #'(let () 183 | (local-require (only-in sugar/debug REPORT-ID)) 184 | (REPORT-ID STX)))))) 185 | -------------------------------------------------------------------------------- /sugar/list.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax 3 | racket/base) 4 | racket/list 5 | racket/match 6 | racket/function 7 | "define.rkt") 8 | 9 | (define (increasing-nonnegative-list? x) 10 | (and (list? x) (or (empty? x) (apply < -1 x)))) 11 | 12 | (define+provide+safe (trimf xs test-proc) 13 | (list? procedure? . -> . list?) 14 | (unless (list? xs) 15 | (raise-argument-error 'trimf "list?" xs)) 16 | (dropf-right (dropf xs test-proc) test-proc)) 17 | 18 | (define (slicef-and-filter-split-helper xs pred [separate-negated? #f]) 19 | (let loop ([xs xs][negating? #f][acc empty][negated-acc empty]) 20 | (match xs 21 | [(? empty?) (if separate-negated? 22 | (values (reverse acc) (reverse negated-acc)) 23 | (reverse acc))] 24 | [(list* (? (if negating? (negate pred) pred) pred-xs) ... other-xs) 25 | (cond 26 | [(and negating? separate-negated?) 27 | (loop other-xs 28 | (not negating?) 29 | acc 30 | (match pred-xs 31 | [(? empty?) negated-acc] 32 | [_ (cons pred-xs negated-acc)]))] 33 | [else 34 | (loop other-xs 35 | (not negating?) 36 | (match pred-xs 37 | [(? empty?) acc] 38 | [_ (cons pred-xs acc)]) 39 | negated-acc)])]))) 40 | 41 | 42 | (define+provide+safe (slicef xs pred) 43 | (list? procedure? . -> . (listof list?)) 44 | (unless (list? xs) 45 | (raise-argument-error 'slicef "list?" xs)) 46 | (slicef-and-filter-split-helper xs pred)) 47 | 48 | (define+provide+safe (slicef-at xs pred [force? #f]) 49 | ((list? procedure?) (boolean?) . ->* . (listof list?)) 50 | (unless (list? xs) 51 | (raise-argument-error 'slicef-at "list?" xs)) 52 | (unless (procedure? pred) 53 | (raise-argument-error 'slicef-at "procedure?" pred)) 54 | (let loop ([xs xs][acc empty]) 55 | (match xs 56 | [(== empty) (reverse acc)] 57 | [(list* (? pred pred-x) (? (negate pred) not-pred-xs) ... tail) 58 | (loop tail (cons (cons pred-x not-pred-xs) acc))] 59 | [(list* (? (negate pred) not-pred-xs) ... tail) 60 | (loop tail (if force? acc (cons not-pred-xs acc)))]))) 61 | 62 | (define+provide+safe (slicef-after xs pred [force? #f]) 63 | ((list? procedure?) (boolean?) . ->* . (listof list?)) 64 | (unless (list? xs) 65 | (raise-argument-error 'slicef-after "list?" xs)) 66 | (unless (procedure? pred) 67 | (raise-argument-error 'slicef-after "procedure?" pred)) 68 | (let loop ([xs xs][acc empty]) 69 | (match xs 70 | [(== empty) (reverse acc)] 71 | [(list* (? (negate pred) not-pred-xs) ... (? pred pred-x) tail) 72 | (loop tail (cons (append not-pred-xs (list pred-x)) acc))] 73 | [tail (loop empty (if force? acc (cons tail acc)))]))) 74 | 75 | (define+provide+safe (slice-at xs len [force? #f]) 76 | ((list? exact-nonnegative-integer?) (boolean?) . ->* . (listof list?)) 77 | (unless (list? xs) 78 | (raise-argument-error 'slice-at "list?" xs)) 79 | (unless (and (integer? len) (positive? len)) 80 | (raise-argument-error 'slice-at "positive integer for sublist length" len)) 81 | (let loop ([xs xs][slices empty]) 82 | (if (< (length xs) len) 83 | (reverse (if (or force? (empty? xs)) 84 | slices 85 | (cons xs slices))) 86 | (match/values (split-at xs len) 87 | [(subxs rest) (loop rest (cons subxs slices))])))) 88 | 89 | (define+provide+safe (partition* pred xs) 90 | (predicate/c list? . -> . (values list? list?)) 91 | (unless (list? xs) 92 | (raise-argument-error 'partition* "list?" xs)) 93 | (slicef-and-filter-split-helper xs pred 'drop-negated)) 94 | 95 | (define+provide+safe (filter-split xs pred) 96 | (list? predicate/c . -> . (listof list?)) 97 | (unless (list? xs) 98 | (raise-argument-error 'filter-split "list?" xs)) 99 | ;; same idea as slicef, but the negated items are dropped 100 | (define-values (negated-pred-xs _) (partition* (negate pred) xs)) 101 | negated-pred-xs) 102 | 103 | (define+provide+safe (frequency-hash xs) 104 | (list? . -> . hash?) 105 | (unless (list? xs) 106 | (raise-argument-error 'frequency-hash "list?" xs)) 107 | (define counter (make-hash)) 108 | (for ([item (in-list xs)]) 109 | (hash-update! counter item add1 0)) 110 | counter) 111 | 112 | (define (->list x) 113 | (match x 114 | [(? list? x) x] 115 | [(? vector?) (vector->list x)] 116 | [(? string?) (string->list x)] 117 | [else (raise-argument-error '->list "item that can be converted to list" x)])) 118 | 119 | (define+provide+safe (members-unique? x) 120 | ((or/c list? vector? string?) . -> . boolean?) 121 | (match (->list x) 122 | [(? list? x) (= (length (remove-duplicates x)) (length x))] 123 | [_ (raise-argument-error 'members-unique? "list, vector, or string" x)])) 124 | 125 | (define+provide+safe (members-unique?/error x) 126 | ((or/c list? vector? string?) . -> . boolean?) 127 | (match (members-unique? x) 128 | [(== #false) 129 | (define duplicate-keys (filter values (hash-map (frequency-hash (->list x)) 130 | (λ (element freq) (and (> freq 1) element))))) 131 | (error (string-append "members-unique? failed because " (if (= (length duplicate-keys) 1) 132 | "item isn't" 133 | "items aren't") " unique:") duplicate-keys)] 134 | [result result])) 135 | 136 | (provide+safe values->list) 137 | (define-syntax (values->list stx) 138 | (syntax-case stx () 139 | [(_ VALUES-EXPR) #'(call-with-values (λ () VALUES-EXPR) list)])) 140 | 141 | (define+provide+safe (sublist xs i j) 142 | (list? exact-nonnegative-integer? exact-nonnegative-integer? . -> . list?) 143 | (unless (list? xs) 144 | (raise-argument-error 'sublist "list?" xs)) 145 | (cond 146 | [(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))] 147 | [(>= j i) (for/list ([(x idx) (in-indexed xs)] 148 | #:when (<= i idx (sub1 j))) 149 | x)] 150 | [else (raise-argument-error 'sublist (format "starting index larger than ending index" (list i j)))])) 151 | 152 | (define+provide+safe (break-at xs bps-in) 153 | (list? any/c . -> . (listof list?)) 154 | (unless (list? xs) 155 | (raise-argument-error 'break-at "list" xs)) 156 | (define bps ((if (list? bps-in) values list) bps-in)) 157 | (when (ormap (λ (bp) (<= (length xs) bp)) bps) 158 | (raise-argument-error 'break-at 159 | (format "breakpoints not greater than or equal to input list length = ~a" (length xs)) bps)) 160 | (unless (increasing-nonnegative-list? bps) 161 | (raise-argument-error 'break-at "increasing-nonnegative-list" bps)) 162 | ;; easier to do back to front, because then the list index for each item won't change during the recursion 163 | ;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition 164 | ;; because breaking at zero means we've reached the start of the list 165 | (let loop ([xs xs][bps (reverse (cons 0 bps))][acc empty]) 166 | (match bps 167 | [(cons (? zero?) _) (cons xs acc)] ; return whatever's left, because no more splits are possible 168 | [_ (match/values (split-at xs (car bps)) 169 | [(head tail) (loop head (cdr bps) (cons tail acc))])]))) 170 | 171 | (define (shift-base xs how-far fill-item cycle caller) 172 | (unless (list? xs) 173 | (raise-argument-error caller "list?" xs)) 174 | (define abs-how-far (if cycle 175 | (modulo (abs how-far) (length xs)) 176 | (abs how-far))) 177 | (define (make-fill thing) (if cycle thing (make-list abs-how-far fill-item))) 178 | (cond 179 | [(> abs-how-far (length xs)) 180 | (raise-argument-error caller 181 | (format "index not larger than list length ~a" (length xs)) 182 | (* (if (eq? caller 'shift-left) -1 1) how-far))] 183 | [(zero? how-far) xs] 184 | [(positive? how-far) 185 | (match/values (split-at-right xs abs-how-far) 186 | [(head tail) (append (make-fill tail) head)])] 187 | [else ; how-far is negative 188 | (match/values (split-at xs abs-how-far) 189 | [(head tail) (append tail (make-fill head))])])) 190 | 191 | (define+provide+safe (shift xs how-far [fill-item #f] [cycle #f]) 192 | ((list? integer?) (any/c boolean?) . ->* . list?) 193 | (shift-base xs how-far fill-item cycle 'shift)) 194 | 195 | (define+provide+safe (shift-left xs how-far [fill-item #f] [cycle #f]) 196 | ((list? integer?) (any/c boolean?) . ->* . list?) 197 | (shift-base xs (- how-far) fill-item cycle 'shift-left)) 198 | 199 | (define+provide+safe (shift-cycle xs how-far) 200 | (list? integer? . -> . list?) 201 | (shift-base xs how-far #false #true 'shift-cycle)) 202 | 203 | (define+provide+safe (shift-left-cycle xs how-far) 204 | (list? integer? . -> . list?) 205 | (shift-base xs (- how-far) #false #true 'shift-left-cycle)) 206 | 207 | (define+provide+safe (shifts xs how-fars [fill-item #f] [cycle #f]) 208 | ((list? (listof integer?)) (any/c boolean?) . ->* . (listof list?)) 209 | (unless (list? xs) 210 | (raise-argument-error 'shifts "list?" xs)) 211 | (map (λ (how-far) (shift xs how-far fill-item cycle)) how-fars)) 212 | 213 | (define+provide+safe (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f]) 214 | ((list? (or/c (listof integer?) integer?)) (any/c boolean?) . ->* . any) 215 | (apply values ((if (list? shift-amount-or-amounts) 216 | shifts 217 | shift) xs shift-amount-or-amounts fill-item cycle))) -------------------------------------------------------------------------------- /sugar/scribblings/list.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require scribble/eval (for-label racket sugar racket/function)) 4 | 5 | @(define my-eval (make-base-eval)) 6 | @(my-eval `(require sugar racket/list racket/function)) 7 | 8 | @title{Lists} 9 | @defmodule[#:multi (sugar/list (submod sugar/list safe))] 10 | 11 | 12 | 13 | @defproc[ 14 | (trimf 15 | [lst list?] 16 | [pred procedure?]) 17 | list?] 18 | Drop elements from each end of @racket[_lst] that satisfy @racket[_pred]. Exactly equivalent to @racket[(dropf-right (dropf _lst _pred) _pred)]. 19 | 20 | @examples[#:eval my-eval 21 | (trimf '(1 2 3 a b c 4 5 6) integer?) 22 | (trimf '(1 2 3 a b c) integer?) 23 | (trimf '(a b c) integer?) 24 | (trimf '(a b c 1 2 3 d e f) integer?)] 25 | 26 | 27 | @defproc[ 28 | (filter-split 29 | [lst list?] 30 | [pred procedure?]) 31 | (listof list?)] 32 | Like @racket[string-split], but for lists. Drop elements from anywhere in @racket[_lst] that satisfy @racket[_pred] — ends, middle, you name it — and return a list of the sublists that remain. 33 | 34 | @examples[#:eval my-eval 35 | (filter-split '(1 a b c 2 d e f 3) integer?) 36 | (filter-split '(1 a b c 2 d e f 3) (negate integer?))] 37 | 38 | @defproc[ 39 | (partition* 40 | [pred procedure?] 41 | [lst list?]) 42 | (values list? list?)] 43 | Like @racket[partition], but contiguous groups of elements matching (or not matching) @racket[_pred] are kept together in sublists. 44 | 45 | Same as @racket[(values (filter-split _lst _pred) (filter-split _lst (negate _pred)))], but only traverses the list once. 46 | 47 | @examples[#:eval my-eval 48 | (partition* integer? '(1 a b c 2 d e f 3)) 49 | (partition* (negate integer?) '(1 a b c 2 d e f 3))] 50 | 51 | @defproc[ 52 | (slice-at 53 | [lst list?] 54 | [len (and/c integer? positive?)] 55 | [force? boolean? #f]) 56 | (listof list?)] 57 | Divide @racket[_lst] into sublists of length @racket[_len]. If @racket[_lst] cannot be divided evenly by @racket[_len], the last sublist will be shorter. If this displeases you, set @racket[_force?] to @racket[#t] and a stumpy final sublist will be ignored. 58 | 59 | @examples[#:eval my-eval 60 | (slice-at (range 5) 1) 61 | (slice-at (range 5) 2) 62 | (slice-at (range 5) 2 #t) 63 | (slice-at (range 5) 3) 64 | (slice-at (range 5) 5) 65 | (slice-at (range 5) 5 #t) 66 | (slice-at (range 5) 100000) 67 | (slice-at (range 5) 100000 #t)] 68 | 69 | @defproc[ 70 | (slicef 71 | [lst list?] 72 | [pred procedure?]) 73 | (listof list?)] 74 | Divide @racket[_lst] into sublists that are homogeneously @racket[_pred] or not @racket[_pred]. If none of the elements match @racket[_pred], there is no slice to be made, and the result is the whole input list. 75 | 76 | @examples[#:eval my-eval 77 | (slicef '(1 2 2 1 2) even?) 78 | (slicef (range 5) odd?) 79 | (slicef (range 5) string?)] 80 | 81 | 82 | @defproc[ 83 | (slicef-at 84 | [lst list?] 85 | [pred procedure?] 86 | [force? boolean? #f]) 87 | (listof list?)] 88 | Divide @racket[_lst] into sublists, each starting with an element matching @racket[_pred]. The first element of the first sublist may not match @racket[_pred]. But if you really & truly want only the sublists starting with an element matching @racket[_pred], set @racket[_force?] to @racket[#true]. 89 | 90 | If none of the elements match @racket[_pred], there is no slice to be made, and the result is the whole input list. 91 | 92 | @examples[#:eval my-eval 93 | (slicef-at (range 5) even?) 94 | (slicef-at '(1 2 2 1 2) even?) 95 | (slicef-at '(1 2 2 1 2) even? #t) 96 | (slicef-at (range 5) odd?) 97 | (slicef-at (range 5) odd? #t)] 98 | 99 | @defproc[ 100 | (slicef-after 101 | [lst list?] 102 | [pred procedure?] 103 | [force? boolean? #f]) 104 | (listof list?)] 105 | Divide @racket[_lst] into sublists, each ending with an element matching @racket[_pred]. The last element of the last sublist may not match @racket[_pred]. But if you really & truly want only the sublists ending with an element matching @racket[_pred], set @racket[_force?] to @racket[#true]. 106 | 107 | If none of the elements match @racket[_pred], there is no slice to be made, and the result is the whole input list. 108 | 109 | @examples[#:eval my-eval 110 | (slicef-after '(1 2 2 1 2) even?) 111 | (slicef-after (range 5) odd?) 112 | (slicef-after (range 5) odd? #true) 113 | (slicef-after (range 5) string?)] 114 | 115 | 116 | @defproc[ 117 | (frequency-hash 118 | [lst list?]) 119 | hash?] 120 | Count the frequency of each element in @racket[_lst], and return a hash whose keys are the unique elements of @racket[_lst], and each value is the frequency of that element within @racket[_lst]. 121 | 122 | @examples[#:eval my-eval 123 | (frequency-hash '(a b b c c c)) 124 | (frequency-hash '(c b c a b c)) 125 | ] 126 | 127 | 128 | 129 | @defproc[ 130 | (members-unique? 131 | [container (or/c list? vector? string?)]) 132 | boolean?] 133 | Return @racket[#t] if every element in @racket[_container] is unique, otherwise @racket[#f]. 134 | 135 | @examples[#:eval my-eval 136 | (members-unique? '(a b c d e f)) 137 | (members-unique? '(a b c d e f a)) 138 | ] 139 | 140 | @defproc[ 141 | (members-unique?/error 142 | [container (or/c list? vector? string?)]) 143 | boolean?] 144 | Same as @racket[members-unique?], but if the members are not unique, raises a descriptive error rather than returning @racket[#f]. 145 | 146 | @examples[#:eval my-eval 147 | (members-unique?/error '(a b c d e f)) 148 | (members-unique?/error '(a b c d e f a)) 149 | (members-unique?/error '(a b c d e f a b)) 150 | ] 151 | 152 | 153 | @defform[(values->list values)] 154 | Convert @racket[_values] to a simple list. 155 | 156 | @examples[#:eval my-eval 157 | (split-at '(a b c d e f) 3) 158 | (values->list (split-at '(a b c d e f) 3)) 159 | ] 160 | 161 | 162 | @defproc[ 163 | (sublist 164 | [lst list?] 165 | [start-idx (and/c integer? (not/c negative?))] 166 | [end-idx (and/c integer? (not/c negative?))]) 167 | list?] 168 | Return a sublist of the @racket[_lst] starting with item @racket[_start-idx] and ending one item @bold{before} item @racket[_end-idx]. (Similar to how list slices are denominated in Python.) Thus the maximum value for @racket[_end-idx] is @racketfont{(length @racket[_lst])}. Errors will be triggered by nonsensical values for @racket[_end-idx]. 169 | 170 | Bear in mind that @racket[sublist] is built for convenience, not performance. If you need to do a lot of random access into the middle of an ordered sequence of items, you'd be better off putting them into a @racket[vector] and using @racket[vector-copy]. 171 | 172 | @examples[#:eval my-eval 173 | (sublist '(0 1 2 3 4 5 6 7 8) 0 8) 174 | (sublist '(0 1 2 3 4 5 6 7 8) 8 9) 175 | (sublist '(0 1 2 3 4 5 6 7 8) 2 5) 176 | (sublist '(0 1 2 3 4 5 6 7 8) 5 2) 177 | (sublist '(0 1 2 3 4 5 6 7 8) 2 10) 178 | ] 179 | 180 | 181 | @defproc[ 182 | (break-at 183 | [lst list?] 184 | [indexes (or/c integer? (listof integer?))]) 185 | (listof list?)] 186 | Break @racket[_lst] into smaller lists at the index positions in @racket[_indexes]. If a single integer value is given for @racket[_indexes], it's treated as a one-element list. Errors will arise if a breakpoint index exceeds the length of the list, or if the breakpoints are not increasing. 187 | 188 | @examples[#:eval my-eval 189 | (break-at '(0 1 2 3 4 5 6 7 8) 3) 190 | (break-at '(0 1 2 3 4 5 6 7 8) '(3)) 191 | (break-at '(0 1 2 3 4 5 6 7 8) '(3 6)) 192 | (break-at '(0 1 2 3 4 5 6 7 8) '(3 6 8)) 193 | (break-at '(0 1 2 3 4 5 6 7 8) '(3 6 8 10)) 194 | ] 195 | 196 | @defproc[ 197 | (shift 198 | [lst list?] 199 | [how-far integer?] 200 | [fill-item any/c #f] 201 | [cycle? boolean? #f]) 202 | list?] 203 | Move the items in @racket[_lst] to the right (if @racket[_how-far] is positive) or left (if @racket[_how-far] is negative). By default, vacated spaces in the list are filled with @racket[_fill-item]. But if @racket[_cycle?] is true, elements of the list wrap around (and @racket[_fill-item] is ignored). Either way, the result list is always the same length as the input list. (If you don't care about the lengths being the same, you probably want @racket[take] or @racket[drop] instead.) If @racket[_how-far] is 0, return the original list. If @racket[_how-far] is bigger than the length of @racket[_lst], and @racket[_cycle] is not true, raise an error. 204 | 205 | @examples[#:eval my-eval 206 | (define xs (range 5)) 207 | (shift xs 2) 208 | (shift xs -2 0) 209 | (shift xs 2 'boing) 210 | (shift xs 2 'boing #t) 211 | (shift xs 0) 212 | (shift xs 42) 213 | ] 214 | 215 | @defproc[ 216 | (shift-left 217 | [lst list?] 218 | [how-far integer?] 219 | [fill-item any/c #f] 220 | [cycle? boolean? #f]) 221 | list?] 222 | Like @racket[shift], but the list is shifted left when @racket[_how-far] is positive, and right when it's negative. Otherwise identical. 223 | 224 | @examples[#:eval my-eval 225 | (define xs (range 5)) 226 | (shift-left xs 2) 227 | (shift-left xs -2 0) 228 | (shift-left xs 2 'boing) 229 | (shift-left xs 2 'boing #t) 230 | (shift-left xs 0) 231 | (shift-left xs 42) 232 | ] 233 | 234 | @deftogether[( 235 | @defproc[ 236 | (shift-cycle 237 | [lst list?] 238 | [how-far integer?]) 239 | list?] 240 | @defproc[ 241 | (shift-left-cycle 242 | [lst list?] 243 | [how-far integer?]) 244 | list?] 245 | )] 246 | Like @racket[shift] and @racket[shift-left], but automatically invokes cycle mode. @racket[_how-far] can be any size. 247 | 248 | @examples[#:eval my-eval 249 | (define xs (range 5)) 250 | (shift-cycle xs 2) 251 | (shift-cycle xs -2) 252 | (shift-cycle xs 0) 253 | (shift-cycle xs 42) 254 | (shift-left-cycle xs 2) 255 | (shift-left-cycle xs -2) 256 | (shift-left-cycle xs 0) 257 | (shift-left-cycle xs 42) 258 | ] 259 | 260 | 261 | @defproc[ 262 | (shifts 263 | [lst list?] 264 | [how-far (listof integer?)] 265 | [fill-item any/c #f] 266 | [cycle? boolean? #f]) 267 | (listof list?)] 268 | Same as @racket[shift], but @racket[_how-far] is a list of integers rather than a single integer, and the result is a list of lists rather than a single list. 269 | 270 | @examples[#:eval my-eval 271 | (define xs (range 5)) 272 | (shifts xs '(-2 2)) 273 | (shifts xs '(-2 2) 0) 274 | (shifts xs '(-2 2) 'boing) 275 | (shifts xs '(-2 2) 'boing #t) 276 | ] 277 | 278 | @defproc[ 279 | (shift/values 280 | [lst list?] 281 | [how-far (or/c integer? (listof integer?))] 282 | [fill-item any/c #f]) 283 | any] 284 | When @racket[_how-far] is a single integer, same as @racket[shift], but the resulting list is returned as values. When @racket[_how-far] is a list of integers, same as @racket[shifts], but the resulting lists are returned as multiple values rather than as a list of lists. 285 | 286 | @examples[#:eval my-eval 287 | (define xs (range 5)) 288 | (shift xs 1) 289 | (shift/values xs 1) 290 | (shifts xs '(-1 0 1)) 291 | (shift/values xs '(-1 0 1)) 292 | ] 293 | 294 | -------------------------------------------------------------------------------- /sugar/test/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require (for-syntax racket/syntax 3 | syntax/strip-context)) 4 | 5 | (define-syntax (eval-with-and-without-contracts stx) 6 | (syntax-case stx () 7 | [(_ EXPRS ...) 8 | (with-syntax ([MODULE-WITHOUT-CONTRACTS (generate-temporary)] 9 | [MODULE-WITH-CONTRACTS (generate-temporary)]) 10 | (replace-context stx 11 | #'(begin 12 | (module MODULE-WITHOUT-CONTRACTS racket 13 | (require rackunit "../main.rkt" net/url) 14 | EXPRS ...) 15 | (require 'MODULE-WITHOUT-CONTRACTS) 16 | (module MODULE-WITH-CONTRACTS racket 17 | (require rackunit (submod "../main.rkt" safe) net/url) 18 | EXPRS ...) 19 | (require 'MODULE-WITH-CONTRACTS))))])) 20 | 21 | (eval-with-and-without-contracts 22 | (check-equal? (->int 42) 42) 23 | (check-equal? (->int 42.1) 42) 24 | (check-equal? (->int 42+3i) 42) 25 | (check-equal? (->int "42") 42) 26 | (check-equal? (->int '42) 42) 27 | (check-equal? (->int (string->path "42")) 42) 28 | (check-equal? (->int #\A) 65) 29 | (check-equal? (->int (make-list 42 null)) 42) 30 | 31 | (check-equal? (->string "foo") "foo") 32 | (check-equal? (->string #"foo") "foo") 33 | (check-equal? (->string '()) "") 34 | (check-equal? (->string (void)) "") 35 | (check-equal? (->string 'foo) "foo") 36 | (check-equal? (->string 123) "123") 37 | (check-equal? (->string (string->url "foo/bar.html")) "foo/bar.html") 38 | (define file-name-as-text "foo.txt") 39 | (check-equal? (->string (string->path file-name-as-text)) file-name-as-text) 40 | (check-equal? (->string #\¶) "¶") 41 | 42 | (check-equal? (->path "foo") (string->path "foo")) 43 | (check-equal? (->path #"foo") (string->path "foo")) 44 | (check-equal? (->path 'foo) (string->path "foo")) 45 | (check-equal? (->path 123) (string->path "123")) 46 | (check-equal? (->path (string->url "foo/bar.html")) (string->path "foo/bar.html")) 47 | (check-equal? (->path (string->url "/foo/bar.html")) (string->path "/foo/bar.html")) 48 | 49 | (check-equal? (->list '(1 2 3)) '(1 2 3)) 50 | (check-equal? (->list (list->vector '(1 2 3))) '(1 2 3)) 51 | (check-not-false (andmap (lambda (e) (member e '(1 2 3))) (->list (set 1 2 3)))) 52 | (check-equal? (->list "foo") (list "foo")) 53 | 54 | (check-true (->boolean #t)) 55 | (check-false (->boolean #f)) 56 | (check-true (->boolean "#f")) 57 | (check-true (->boolean "foo")) 58 | (check-true (->boolean '())) 59 | (check-true (->boolean '(1 2 3))) 60 | 61 | 62 | (module dp racket/base 63 | (require "../define.rkt") 64 | (define+provide (dp-f x #:y [y 42] . zs) 65 | (apply + x y zs))) 66 | 67 | (require 'dp) 68 | (check-equal? (dp-f 1 #:y 0 2 3) 6) 69 | 70 | (module dps racket/base 71 | (require sugar/define) 72 | (define+provide+safe (dps-f x #:y [y 42] . zs) 73 | ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . integer?) 74 | (apply + x y zs))) 75 | 76 | (require 'dps) 77 | (check-equal? (dps-f 1 #:y 0 2 3) 6) 78 | (require (prefix-in safe: (submod 'dps safe))) 79 | (check-equal? (safe:dps-f 1 #:y 0 2 3) 6) 80 | (check-exn exn:fail? (λ _ (safe:dps-f 'foo))) 81 | 82 | (module dpsb racket/base 83 | (require sugar/define) 84 | (define+provide+safe dpsb-f 85 | ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . integer?) 86 | (λ(x #:y [y 42] . zs) (apply + x y zs)))) 87 | 88 | (require 'dpsb) 89 | (check-equal? (dpsb-f 1 #:y 0 2 3) 6) 90 | (require (prefix-in safe: (submod 'dpsb safe))) 91 | (check-equal? (safe:dpsb-f 1 #:y 0 2 3) 6) 92 | (check-exn exn:fail? (λ _ (safe:dpsb-f 'foo))) 93 | 94 | (module ps racket/base 95 | (require "../define.rkt") 96 | (provide+safe [ps-f ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . integer?)]) 97 | (define (ps-f x #:y [y 42] . zs) 98 | (apply + x y zs))) 99 | 100 | (require 'ps) 101 | (check-equal? (ps-f 1 #:y 0 2 3) 6) 102 | (require (prefix-in safe: (submod 'ps safe))) 103 | (check-equal? (safe:ps-f 1 #:y 0 2 3) 6) 104 | (check-exn exn:fail? (λ _ (safe:ps-f 'foo))) 105 | 106 | (module dcp racket/base 107 | (require "../define.rkt" rackunit) 108 | (define/contract+provide (dcp-f x #:y [y 42] . zs) 109 | ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . integer?) 110 | (apply + x y zs)) 111 | (check-exn exn:fail? (λ _ (dcp-f 'foo)))) 112 | 113 | (require 'dcp) 114 | (check-equal? (dcp-f 1 #:y 0 2 3) 6) 115 | (check-exn exn:fail? (λ _ (dcp-f 'foo))) 116 | 117 | (module dpc racket/base 118 | (require "../define.rkt" rackunit) 119 | (define+provide/contract (dpc-f x #:y [y 42] . zs) 120 | ((integer?) (#:y integer?) #:rest (listof integer?) . ->* . list?) 121 | (list* x y zs)) 122 | (check-equal? (dpc-f 'foo) '(foo 42))) ; locally, no contract triggered 123 | 124 | (require 'dpc) 125 | (check-equal? (dpc-f 1) '(1 42)) 126 | (check-exn exn:fail? (λ _ (dpc-f 'foo))) 127 | 128 | (check-true (members-unique? '(a b c))) 129 | (check-false (members-unique? '(a b c c))) 130 | (check-true (members-unique? "zoey")) 131 | (check-false (members-unique? "zooey")) 132 | 133 | (check-equal? (trimf (list 4 1 2 3 4) even?) '(1 2 3)) 134 | (check-equal? (trimf (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8)) 135 | (check-equal? (filter-split '(1 1 2 3 4 4 5 6) even?) '((1 1)(3)(5))) 136 | (check-equal? (let-values ([(preds not-preds) (partition* even? '(1 1 2 3 4 4 5 6))]) 137 | (list preds not-preds)) (list '((2)(4 4)(6)) '((1 1)(3)(5)))) 138 | 139 | (define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt")) 140 | (match-define (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (map ->path foo-path-strings)) 141 | ;; test the sample paths before using them for other tests 142 | (define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path)) 143 | (for-each check-equal? (map ->string foo-paths) foo-path-strings) 144 | 145 | (check-false (has-ext? foo-path 'txt)) 146 | (check-true (foo.txt-path . has-ext? . 'txt)) 147 | (check-true ((->path "foo.TXT") . has-ext? . 'txt)) 148 | (check-true (has-ext? foo.bar.txt-path 'txt)) 149 | (check-false (foo.bar.txt-path . has-ext? . 'doc)) ; wrong extension 150 | (check-exn exn:fail:contract? (λ () (has-ext? #f "foo"))) 151 | (check-exn exn:fail:contract? (λ () (has-ext? "foo" #f))) 152 | 153 | (check-equal? (get-ext (->path "foo.txt")) "txt") 154 | (check-false (get-ext "foo")) 155 | (check-false (get-ext ".foo")) 156 | (check-exn exn:fail:contract? (λ () (get-ext #f))) 157 | 158 | (check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")) 159 | (check-exn exn:fail:contract? (λ () (add-ext "foo" #f))) 160 | (check-exn exn:fail:contract? (λ () (add-ext #f "foo" ))) 161 | 162 | (check-equal? (remove-ext foo-path) foo-path) 163 | (check-equal? (remove-ext (->path ".foo.txt")) (->path ".foo")) 164 | (check-equal? (remove-ext foo.txt-path) foo-path) 165 | (check-equal? (remove-ext foo.bar.txt-path) foo.bar-path) 166 | (check-not-equal? (remove-ext foo.bar.txt-path) foo-path) ; does not remove all extensions 167 | ;; test remove-ext on paths that have "." prefix 168 | (check-equal? (remove-ext (->path "./foo.txt.bar")) (->path "./foo.txt")) 169 | (check-equal? (remove-ext (->path "../foo.txt.bar")) (->path "../foo.txt")) 170 | (check-equal? (remove-ext (->path "/hidden/file/.foo.txt.bar")) (->path "/hidden/file/.foo.txt")) 171 | 172 | (check-equal? (remove-ext* foo-path) foo-path) 173 | (check-equal? (remove-ext* foo.txt-path) foo-path) 174 | (check-equal? (remove-ext* (->path ".foo.txt")) (->path ".foo")) 175 | (check-not-equal? (remove-ext* foo.bar.txt-path) foo.bar-path) ; removes more than one ext 176 | (check-equal? (remove-ext* foo.bar.txt-path) foo-path) 177 | ;; test remove-ext* on paths that have "." prefix 178 | (check-equal? (remove-ext* (->path "./foo.txt.bar")) (->path "./foo")) 179 | (check-equal? (remove-ext* (->path "../foo.txt.bar")) (->path "../foo")) 180 | (check-equal? (remove-ext* (->path "/hidden/file/.foo.txt.bar")) (->path "/hidden/file/.foo")) 181 | 182 | (check-true (has-binary-ext? "foo.MP3")) 183 | (check-false (has-binary-ext? "foo.py")) 184 | 185 | (check-equal? (slice-at (range 5) 1) '((0) (1) (2) (3) (4))) 186 | (check-equal? (slice-at (range 5) 2) '((0 1) (2 3) (4))) 187 | (check-equal? (slice-at (range 5) 2 #t) '((0 1) (2 3))) 188 | (check-equal? (slice-at (range 5) 3) '((0 1 2) (3 4))) 189 | (check-equal? (slice-at (range 5) 3 #t) '((0 1 2))) 190 | 191 | (check-equal? (slicef '(0 1 2 0 0 0 3) positive?) '((0) (1 2) (0 0 0) (3))) 192 | (check-equal? (slicef '(0 1 2 0 0 0 3) positive?) (slicef '(0 1 2 0 0 0 3) zero?)) 193 | (check-equal? (slicef '(1 (1) (1) 1 1 1 (1)) list?) '((1) ((1) (1)) (1 1 1) ((1)))) 194 | (check-equal? (slicef '(1 2 3 4 5) list?) '((1 2 3 4 5))) 195 | 196 | (check-equal? (slicef-at (range 5) even?) '((0 1) (2 3) (4))) 197 | (check-equal? (slicef-at (range 5) odd?) '((0) (1 2) (3 4))) 198 | (check-equal? (slicef-at (range 5) odd? #t) '((1 2) (3 4))) 199 | (check-equal? (slicef-at (range 5) procedure?) '((0 1 2 3 4))) 200 | 201 | (check-equal? (slicef-at '(1 2 2 1 2) even?) '((1) (2) (2 1) (2))) 202 | (check-equal? (slicef-at '(1 2 2 1 2) even? #t) '((2) (2 1) (2))) 203 | 204 | (check-equal? (slicef-after (range 5) even?) '((0) (1 2) (3 4))) 205 | (check-equal? (slicef-after (range 5) odd?) '((0 1) (2 3) (4))) 206 | (check-equal? (slicef-after (range 5) odd? #t) '((0 1) (2 3))) 207 | (check-equal? (slicef-after (range 5) procedure?) '((0 1 2 3 4))) 208 | 209 | (check-equal? (slicef-after '(2 1 2 2 1) even?) '((2) (1 2) (2) (1))) 210 | (check-equal? (slicef-after '(2 1 2 2 1) even? #t) '((2) (1 2) (2))) 211 | 212 | (check-equal? (sublist (range 5) 0 0) '()) 213 | (check-equal? (sublist (range 5) 0 1) '(0)) 214 | (check-equal? (sublist (range 5) 0 5) '(0 1 2 3 4)) 215 | 216 | (check-equal? (break-at '(5 6 7 8) '()) '((5 6 7 8))) 217 | (check-equal? (break-at '(5 6 7 8) '(0)) '((5 6 7 8))) 218 | (check-equal? (break-at '(5 6 7 8) '(1 2 3)) '((5) (6) (7) (8))) 219 | (check-equal? (break-at '(5 6 7 8) '(1 3)) '((5) (6 7) (8))) 220 | (check-equal? (break-at '(5 6 7 8) '(1)) (break-at '(5 6 7 8) 1)) 221 | 222 | (define xs (range 5)) 223 | (check-equal? (map (λ(a b c) (list a b c)) (shift xs -1) (shift xs 0) (shift xs 1)) '((1 0 #f) (2 1 0) (3 2 1) (4 3 2) (#f 4 3))) 224 | (check-equal? (map (λ(a b c) (list a b c)) (shift xs -1 'ignored #t) (shift xs 0 'ignored #t) (shift xs 1 'ignored #t)) '((1 0 4) (2 1 0) (3 2 1) (4 3 2) (0 4 3))) 225 | (check-equal? (shifts xs '(-1 0 1) 'boing) `((1 2 3 4 boing) ,xs (boing 0 1 2 3))) 226 | (check-equal? (shifts xs '(-1 0 1) 'boing #t) `((1 2 3 4 0) ,xs (4 0 1 2 3))) 227 | (check-equal? (shift xs 5 0) (make-list 5 0)) 228 | (check-exn exn:fail? (λ() (shift xs -10))) 229 | 230 | (check-equal? (map (λ(a b c) (list a b c)) (shift-left xs -1) (shift-left xs 0) (shift-left xs 1)) (map reverse '((1 0 #f) (2 1 0) (3 2 1) (4 3 2) (#f 4 3)))) 231 | 232 | (check-equal? (shift-cycle xs 2) '(3 4 0 1 2)) 233 | (check-equal? (shift-left-cycle xs 2) '(2 3 4 0 1)) 234 | (check-equal? (shift-cycle xs 7) '(3 4 0 1 2)) 235 | (check-equal? (shift-left-cycle xs 7) '(2 3 4 0 1)) 236 | (check-equal? (shift-cycle xs 107) '(3 4 0 1 2)) 237 | (check-equal? (shift-left-cycle xs 107) '(2 3 4 0 1)) 238 | 239 | (check-true (urlish? (->path "/Users/MB/home.html"))) 240 | (check-true (urlish? "/Users/MB/home.html?foo=bar")) 241 | (check-true (urlish? (->symbol "/Users/MB/home"))) 242 | 243 | (check-true (pathish? (->path "/Users/MB/home"))) 244 | (check-true (pathish? "/Users/MB/home")) 245 | (check-true (pathish? (->symbol "/Users/MB/home"))) 246 | 247 | (check-equal? (filter-split '("foo" " " "bar" "\n" "\n" "ino") (λ(x) (< (string-length x) 3))) '(("foo")("bar")("ino"))) 248 | 249 | (check-exn exn:fail? (λ _ (slice-at (range 5) 0))) ; needs a positive integer as second arg 250 | (check-exn exn:fail? (λ _ (slicef-at (range 5) 3))) ; needs a procedure as second arg 251 | 252 | 253 | (define ys (range 5)) 254 | (check-equal? (values->list (shift/values ys -1 'boing)) '(1 2 3 4 boing)) 255 | (check-equal? (values->list (shift/values ys '(-1 0 1) 'boing)) `((1 2 3 4 boing) ,xs (boing 0 1 2 3))) 256 | 257 | (check-equal? "42 = 42\n" (let ([os (open-output-string)]) 258 | (parameterize ([current-error-port os]) 259 | (report 42)) 260 | (get-output-string os))) 261 | 262 | (check-equal? "(quotient/remainder 10 3) = (values 3 1)\n" (let ([os (open-output-string)]) 263 | (parameterize ([current-error-port os]) 264 | (report (quotient/remainder 10 3)) 265 | (get-output-string os))))) 266 | 267 | --------------------------------------------------------------------------------