diff --git a/README.md b/README.md index 9de84fc..9d2fd62 100644 --- a/README.md +++ b/README.md @@ -15,8 +15,4 @@ In safe mode (with contracts): (require (submod sugar safe)) -Or in typed mode: - - (require typed/sugar) - You can [read the docs here](http://pkg-build.racket-lang.org/doc/sugar). diff --git a/cache.rkt b/cache.rkt new file mode 100644 index 0000000..a7f7e9b --- /dev/null +++ b/cache.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require (for-syntax racket/base) "define.rkt") + +(define+provide+safe (make-caching-proc base-proc) + (procedure? . -> . procedure?) + (let ([cache (make-hash)]) + (λ args + (hash-ref! cache args (λ () (apply base-proc args)))))) + +(provide+safe define/caching) +(define-syntax (define/caching stx) + (syntax-case stx () + [(_ (name arg ... . rest-arg) body ...) + #'(define/caching name (λ(arg ... . rest-arg) body ...))] + [(_ name body ...) + #'(define name (make-caching-proc body ...))])) \ No newline at end of file diff --git a/coerce.rkt b/coerce.rkt new file mode 100644 index 0000000..9ad2042 --- /dev/null +++ b/coerce.rkt @@ -0,0 +1,165 @@ +#lang racket/base +(require (for-syntax racket/base racket/syntax)) +(require net/url racket/set racket/sequence "len.rkt" "define.rkt") + +(define-syntax-rule (make-coercion-error-handler target-format x) + (λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format)))) + + +(define+provide+safe (->int x) + (any/c . -> . integer?) + (with-handlers ([exn:fail? (make-coercion-error-handler 'int x)]) + (cond + [(or (integer? x) (real? x)) (inexact->exact (floor x))] + [(complex? x) (->int (real-part x))] + [(string? x) (let ([strnum (string->number x)]) + (if (real? strnum) (->int strnum) (error 'ineligible-string)))] + [(or (symbol? x) (path? x)) (->int (->string x))] + [(char? x) (char->integer x)] + [else (len x)]))) ; covers Lengthable types + + +(define+provide+safe (->string x) + (any/c . -> . string?) + (if (string? x) + x ; fast exit for strings + (with-handlers ([exn:fail? (make-coercion-error-handler 'string x)]) + (cond + [(or (equal? '() x) (void? x)) ""] + [(symbol? x) (symbol->string x)] + [(number? x) (number->string x)] + [(path? x) (path->string x)] + [(char? x) (format "~a" x)] + [(url? x) (url->string x)] + [else (error 'bad-type)])))) + + +;; ->symbol, ->path, and ->url are just variants on ->string +;; two advantages: return correct type, and more accurate error + +;; no need for "Symbolable" type - same as Stringable +(define+provide+safe (->symbol x) + (any/c . -> . symbol?) + (if (symbol? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) + (string->symbol (->string x))))) + + +(define+provide+safe (->path x) + (any/c . -> . path?) + (if (path? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'path x)]) + (cond + [(url? x) (apply build-path (map path/param-path (url-path x)))] + [else (string->path (->string x))])))) + + +(define+provide+safe (->url x) + (any/c . -> . url?) + (with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) + (string->url (->string x)))) + + +(define+provide+safe (->complete-path x) + (any/c . -> . complete-path?) + (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) + (path->complete-path (->path x)))) + + +(define+provide+safe (->list x) + (any/c . -> . list?) + (if (list? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'list x)]) + (cond + [(string? x) (list x)] + [(vector? x) (for/list ([i (in-vector x)]) + i)] + [(set? x) (set->list x)] + ;; conditional sequencing relevant because hash also tests true for `sequence?` + [(hash? x) (hash->list x)] + [(integer? x) (list x)] ; because an integer tests #t for sequence? + [(sequence? x) (sequence->list x)] + ;[(stream? x) (stream->list x)] ;; no support for streams in TR + [else (list x)])))) + + +(define+provide+safe (->vector x) + (any/c . -> . vector?) + (if (vector? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) + (list->vector (->list x))))) + + +(define+provide+safe (->boolean x) + (any/c . -> . boolean?) + (and x #t)) + + +;; coercion contracts & *ish predicates +;; only make sense in untyped code +;; thus they are here. +(define-syntax-rule (make-blame-handler try-proc expected-sym) + (λ(b) + (λ(x) + (with-handlers ([exn:fail? (λ(e) + (raise-blame-error + b x + '(expected: "~a" given: "~e") + expected-sym x))]) + (try-proc x))))) + + +(provide+safe make-coercion-contract) +(define-syntax (make-coercion-contract stx) + (syntax-case stx () + [(_ stem coerce-proc) + (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)] + [can-be-stem? (format-id stx "can-be-~a?" #'stem)]) + #'(make-contract + #:name 'coerce/stem? + #:projection (make-blame-handler coerce-proc 'can-be-stem?)))] + [(_ stem) + (with-syntax ([->stem (format-id stx "->~a" #'stem)]) + #'(make-coercion-contract stem ->stem))])) + + +(define-syntax (define+provide-coercion-contract stx) + (syntax-case stx () + [(_ stem) + (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]) + #'(begin + (provide+safe coerce/stem?) + (define coerce/stem? (make-coercion-contract stem))))])) + + +(define+provide-coercion-contract int) +(define+provide-coercion-contract string) +(define+provide-coercion-contract symbol) +(define+provide-coercion-contract path) +(define+provide-coercion-contract boolean) +(define+provide-coercion-contract list) + + +(define-syntax (make-*ish-predicate stx) + (syntax-case stx () + [(_ stem) + (with-syntax ([stemish? (format-id stx "~aish?" #'stem)] + [->stem (format-id stx "->~a" #'stem)]) + #`(begin + (provide+safe stemish?) + (define (stemish? x) + (with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))])) + + +(make-*ish-predicate int) +(make-*ish-predicate string) +(make-*ish-predicate symbol) +(make-*ish-predicate url) +(make-*ish-predicate complete-path) +(make-*ish-predicate path) +(make-*ish-predicate list) +(make-*ish-predicate vector) \ No newline at end of file diff --git a/sugar/container.rkt b/container.rkt similarity index 100% rename from sugar/container.rkt rename to container.rkt diff --git a/sugar/debug.rkt b/debug.rkt similarity index 55% rename from sugar/debug.rkt rename to debug.rkt index 5047558..942d549 100644 --- a/sugar/debug.rkt +++ b/debug.rkt @@ -1,13 +1,94 @@ #lang racket/base -(require sugar/define) -(require-via-wormhole "../typed/sugar/debug.rkt") +(require (for-syntax racket/base racket/syntax) "define.rkt") (provide+safe report report/line report/file report* report*/line report*/file report-apply repeat time-repeat time-repeat* compare) +(define-syntax (report stx) + (syntax-case stx () + [(_ expr) #'(report expr expr)] + [(_ expr name) + #'(let ([expr-result expr]) + (eprintf "~a = ~v\n" 'name expr-result) + expr-result)])) +(define-syntax (report/line stx) + (syntax-case stx () + [(_ expr) #'(report/line expr expr)] + [(_ expr name) + (with-syntax ([line (syntax-line #'expr)]) + #'(let ([expr-result expr]) + (eprintf "~a = ~v on line ~v\n" 'name expr-result line) + expr-result))])) + + +(define-syntax (report/file stx) + (syntax-case stx () + [(_ expr) #'(report/file expr expr)] + [(_ expr name) + (with-syntax ([file (syntax-source #'expr)] + [line (syntax-line #'expr)]) + #'(let ([expr-result expr]) + (eprintf "~a = ~v on line ~v in \"~a\"\n" 'name expr-result line 'file) + expr-result))])) + + +(define-syntax-rule (define-multi-version multi-name name) + (define-syntax-rule (multi-name x (... ...)) + (begin (name x) (... ...)))) + +(define-multi-version report* report) +(define-multi-version report*/line report/line) +(define-multi-version report*/file report/file) + + +(define-syntax report-apply + (syntax-rules () + [(report-apply proc expr) + (let ([lst expr]) + (report (apply proc lst) (apply proc expr)) + lst)] + [(report-apply proc expr #:line) + (let ([lst expr]) + (report (apply proc lst) (apply proc expr) #:line) + lst)])) + +#| +(define-syntax (verbalize stx) + (syntax-case stx () + [(_ proc args ...) + (with-syntax ([proc-input (format-id stx "args to ~a" #'proc)]) + #'(begin + (let () (report (list args ...) proc-input) (void)) + (report (proc args ...))))])) +|# + + + + +(define-syntax-rule (repeat num expr ...) + (for/last ([i (in-range num)]) + expr ...)) + + +(define-syntax-rule (time-repeat num expr ...) + (time (repeat num expr ...))) + + +(define-syntax (time-repeat* stx) + (syntax-case stx () + [(_ num expr ...) + #'(let ([n num]) + (values (time-repeat n expr) ...))])) + + +(define-syntax (compare stx) + (syntax-case stx () + [(_ expr id id-alt ...) + #'(values expr (let ([id id-alt]) expr) ...)])) + (module reader racket/base (require syntax/module-reader racket/syntax version/utils) (provide (rename-out [debug-read read] diff --git a/sugar/define.rkt b/define.rkt similarity index 100% rename from sugar/define.rkt rename to define.rkt diff --git a/typed/sugar/file.rkt b/file.rkt similarity index 60% rename from typed/sugar/file.rkt rename to file.rkt index 7fa1c40..0d61f04 100644 --- a/typed/sugar/file.rkt +++ b/file.rkt @@ -1,43 +1,48 @@ -#lang typed/racket/base -(require typed/sugar/define "coerce.rkt" "string.rkt" racket/path) +#lang racket/base +(require "define.rkt" racket/set "coerce.rkt" racket/path "string.rkt") -(define/typed+provide (get-enclosing-dir p) - (Pathish -> Path) + +(define+provide+safe (get-enclosing-dir p) + (coerce/path? . -> . path?) (simplify-path (build-path (->path p) 'up))) + ;; does path have a certain extension -(define/typed+provide (has-ext? x ext) - (Pathish Stringish -> Boolean) +(define+provide+safe (has-ext? x ext) + (coerce/path? coerce/string? . -> . coerce/boolean?) (define ext-of-path (filename-extension (->path x))) (->boolean (and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (->string ext)))))) + ;; get file extension as a string, or return #f ;; (consistent with filename-extension behavior) -(define/typed+provide (get-ext x) - (Pathish -> (Option String)) +(define+provide+safe (get-ext x) + (coerce/path? . -> . (or/c #f string?)) (let ([fe-result (filename-extension (->path x))]) (and fe-result (bytes->string/utf-8 fe-result)))) ;; todo: add extensions -(define/typed+provide binary-extensions - (Listof String) +(provide+safe binary-extensions) +(define binary-extensions (map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe))) -(define/typed+provide (has-binary-ext? x) - (Pathish -> Boolean) + +(define+provide+safe (has-binary-ext? x) + (coerce/path? . -> . coerce/boolean?) (let ([x (->path x)]) - (ormap (λ:([ext : String]) (has-ext? x ext)) binary-extensions))) + (ormap (λ(ext) (has-ext? x ext)) binary-extensions))) + ;; put extension on path ;; use local contract here because this function is used within module -(define/typed+provide (add-ext x ext) - (Stringish Stringish -> Path) +(define+provide+safe (add-ext x ext) + (coerce/string? coerce/string? . -> . coerce/path?) (->path (string-append (->string x) "." (->string ext)))) ;; take one extension off path -(define/typed+provide (remove-ext x) - (Pathish -> Path) +(define+provide+safe (remove-ext x) + (coerce/path? . -> . path?) ;; pass through hidden files (those starting with a dot) (let ([x (->path x)]) (if (x . starts-with? . ".") @@ -46,8 +51,8 @@ ;; take all extensions off path -(define/typed+provide (remove-ext* x) - (Pathish -> Path) +(define+provide+safe (remove-ext* x) + (coerce/path? . -> . path?) ;; pass through hidden files (those starting with a dot) (let ([x (->path x)]) (if (x . starts-with? . ".") @@ -55,5 +60,4 @@ (let ([path-with-removed-ext (remove-ext x)]) (if (equal? x path-with-removed-ext) x - (remove-ext* path-with-removed-ext)))))) - + (remove-ext* path-with-removed-ext)))))) \ No newline at end of file diff --git a/sugar/include.rkt b/include.rkt similarity index 99% rename from sugar/include.rkt rename to include.rkt index 38062b0..72d2acf 100644 --- a/sugar/include.rkt +++ b/include.rkt @@ -1,11 +1,10 @@ #lang racket/base - (require (for-syntax racket/base syntax/path-spec racket/private/increader compiler/cm-accomplice racket/match racket/function) - sugar/define) + "define.rkt") (provide+safe include-without-lang-line) diff --git a/info.rkt b/info.rkt index da39db7..77ddf83 100644 --- a/info.rkt +++ b/info.rkt @@ -1,7 +1,6 @@ #lang info -(define collection 'multi) -(define deps '("base" - "typed-racket-lib" - "typed-racket-more" - "rackunit-lib")) -(define build-deps '("scribble-lib" "racket-doc" "typed-racket-doc")) +(define collection "sugar") +(define deps '("base" "rackunit-lib")) +(define build-deps '("scribble-lib" "racket-doc")) +(define scribblings '(("scribblings/sugar.scrbl" ()))) +(define compile-omit-paths '("test")) \ No newline at end of file diff --git a/len.rkt b/len.rkt new file mode 100644 index 0000000..863c944 --- /dev/null +++ b/len.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require "define.rkt" racket/set racket/sequence) + +(define+provide+safe (len x) + ((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?) + (cond + [(list? x) (length x)] + [(string? x) (string-length x)] + [(symbol? x) (len (symbol->string x))] + [(path? x) (len (path->string x))] + [(vector? x) (vector-length x)] + [(hash? x) (len (hash-keys x))] + [(set? x) (len (set->list x))] + [(and (sequence? x) (not (integer? x))) (len (sequence->list x))] + [else (error "len: can't calculate length of" x)])) \ No newline at end of file diff --git a/typed/sugar/list.rkt b/list.rkt similarity index 51% rename from typed/sugar/list.rkt rename to list.rkt index 65140e7..1e59b48 100644 --- a/typed/sugar/list.rkt +++ b/list.rkt @@ -1,23 +1,29 @@ -#lang typed/racket/base -(require (for-syntax racket/base racket/syntax) racket/function sugar/include) -(require (except-in racket/list dropf dropf-right) typed/sugar/define "coerce.rkt" "len.rkt") -(include-without-lang-line "list-helper.rkt") -;; use fully-qualified paths in require, -;; so they'll work when this file is included elsewhere -(provide (all-defined-out)) - -(define/typed+provide (trimf xs test-proc) - (All (A) ((Listof A) (A -> Boolean) -> (Listof A))) +#lang racket/base +(require (for-syntax racket/base) racket/list racket/set racket/function) +(require "len.rkt" "coerce.rkt" "define.rkt") + +(define (list-of-lists? xs) (and (list? xs) (andmap list? xs))) +(define (index? x) (and (integer? x) (not (negative? x)))) + +(define increasing-nonnegative? (λ(xs) (apply < -1 xs))) +(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?)) + +(define (integers? x) (and (list? x) (andmap integer? x))) + + +(define+provide+safe (trimf xs test-proc) + (list? procedure? . -> . list?) (dropf-right (dropf xs test-proc) test-proc)) -(define/typed+provide (slicef xs pred) - (All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A)))) + +(define+provide+safe (slicef xs pred) + (list? procedure? . -> . list-of-lists?) (define-values (last-list list-of-lists last-negating) - (for/fold: ([current-list : (Listof A) empty] - [list-of-lists : (Listof (Listof A)) empty] - [negating? : Boolean #f]) - ([x (in-list xs)]) - (define current-pred (if negating? (λ: ([x : A]) (not (pred x))) pred)) + (for/fold ([current-list empty] + [list-of-lists empty] + [negating? #f]) + ([x (in-list xs)]) + (define current-pred (if negating? (λ (x) (not (pred x))) pred)) (if (current-pred x) (values (cons x current-list) list-of-lists negating?) (values (cons x null) (if (not (empty? current-list)) @@ -26,14 +32,13 @@ (reverse (cons (reverse last-list) list-of-lists))) -(define/typed+provide (slicef-at xs pred [force? #f]) +(define+provide+safe (slicef-at xs pred [force? #f]) ;; with polymorphic function, use cased typing to simulate optional position arguments - (All (A) (case-> ((Listof A) (A -> Boolean) -> (Listof (Listof A))) - ((Listof A) (A -> Boolean) Boolean -> (Listof (Listof A))))) + ((list? procedure?) (boolean?) . ->* . list-of-lists?) (define-values (last-list list-of-lists) - (for/fold: - ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) - ([x (in-list xs)]) + (for/fold + ([current-list empty][list-of-lists empty]) + ([x (in-list xs)]) (if (pred x) (values (cons x null) (if (not (empty? current-list)) (cons (reverse current-list) list-of-lists) @@ -46,11 +51,12 @@ (cdr list-of-lists) list-of-lists))) -(define/typed+provide (slicef-after xs pred) - (All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A)))) + +(define+provide+safe (slicef-after xs pred) + (list? procedure? . -> . list-of-lists?) (define-values (last-list list-of-lists) - (for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) - ([x (in-list xs)]) + (for/fold ([current-list empty][list-of-lists empty]) + ([x (in-list xs)]) (if (pred x) (values empty (cons (reverse (cons x current-list)) list-of-lists)) (values (cons x current-list) list-of-lists)))) @@ -59,13 +65,12 @@ (cons (reverse last-list) list-of-lists)))) -(define/typed+provide (slice-at xs len [force? #f]) +(define+provide+safe (slice-at xs len [force? #f]) ;; with polymorphic function, use cased typing to simulate optional position arguments - (All (A) (case-> ((Listof A) Positive-Integer -> (Listof (Listof A))) - ((Listof A) Positive-Integer Boolean -> (Listof (Listof A))))) + ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?) (define-values (last-list list-of-lists) - (for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) - ([x (in-list xs)][i (in-naturals)]) + (for/fold ([current-list empty][list-of-lists empty]) + ([x (in-list xs)][i (in-naturals)]) (if (= (modulo (add1 i) len) 0) (values empty (cons (reverse (cons x current-list)) list-of-lists)) (values (cons x current-list) list-of-lists)))) @@ -74,11 +79,11 @@ (cons (reverse last-list) list-of-lists)))) -(define/typed+provide (filter-split xs pred) - (All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A)))) +(define+provide+safe (filter-split xs pred) + (list? predicate/c . -> . list-of-lists?) (define-values (last-list list-of-lists) - (for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) - ([x (in-list xs)]) + (for/fold ([current-list empty][list-of-lists empty]) + ([x (in-list xs)]) (if (pred x) (values empty (if (not (empty? current-list)) (cons (reverse current-list) list-of-lists) @@ -88,17 +93,17 @@ (cons (reverse last-list) list-of-lists) list-of-lists))) -(define/typed+provide (frequency-hash xs) - (All (A) ((Listof A) -> (HashTable A Integer))) - (define counter ((inst make-hash A Integer))) + +(define+provide+safe (frequency-hash xs) + (list? . -> . hash?) + (define counter (make-hash)) (for ([item (in-list xs)]) - (hash-update! counter item (λ:([v : Integer]) (add1 v)) (λ _ 0))) + (hash-update! counter item (λ(v) (add1 v)) (λ _ 0))) counter) - -(define/typed+provide (members-unique? x) - (All (A) ((U (Listof A) (Vectorof A) String) -> Boolean)) +(define+provide+safe (members-unique? x) + ((or/c list? vector? string?) . -> . boolean?) (cond [(list? x) (= (len (remove-duplicates x)) (len x))] [(vector? x) (members-unique? (->list x))] @@ -106,12 +111,12 @@ [else (error (format "members-unique? cannot be determined for ~a" x))])) -(define/typed+provide (members-unique?/error x) - (All (A) ((U (Listof A) (Vectorof A) String) -> Boolean)) +(define+provide+safe (members-unique?/error x) + ((or/c list? vector? string?) . -> . boolean?) (define result (members-unique? x)) (if (not result) (let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x)) - (λ:([element : Any] [freq : Integer]) (if (> freq 1) element '()))))]) + (λ(element freq) (if (> freq 1) element '()))))]) (error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1) "item isn’t" "items aren’t") " unique:") duplicate-keys)) @@ -121,30 +126,31 @@ ;; for use inside quasiquote ;; instead of ,(when ...) use ,@(when/splice ...) ;; to avoid voids -(provide when/splice) +(provide+safe when/splice) (define-syntax (when/splice stx) (syntax-case stx () [(_ test body) #'(if test (list body) '())])) -(provide values->list) + +(provide+safe values->list) (define-syntax (values->list stx) (syntax-case stx () [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) -(define/typed+provide (sublist xs i j) - (All (A) ((Listof A) Index Index -> (Listof A))) +(define+provide+safe (sublist xs i j) + (list? index? index? . -> . list?) (cond [(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))] [(>= j i) (take (drop xs i) (- j i))] [else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))])) -(define/typed+provide (break-at xs bps) - (All (A) ((Listof A) (U Nonnegative-Integer (Listof Nonnegative-Integer)) -> (Listof (Listof A)))) +(define+provide+safe (break-at xs bps) + (list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?) (let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list - (when (ormap (λ:([bp : Nonnegative-Integer]) (>= bp (length xs))) bps) + (when (ormap (λ(bp) (>= bp (length xs))) bps) (error 'break-at (format "breakpoint in ~v is greater than or equal to input list length = ~a" bps (length xs)))) ;; easier to do back to front, because then the list index for each item won't change during the recursion ;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition @@ -156,28 +162,33 @@ (cons tail (loop head (cdr bps))))))))) -(define/typed+provide (shift xs how-far [fill-item #f] [cycle #f]) - (All (A) (case-> ((Listof (Option A)) Integer -> (Listof (Option A))) - ((Listof (Option A)) Integer (Option A) -> (Listof (Option A))) - ((Listof (Option A)) Integer (Option A) Boolean -> (Listof (Option A))))) +(define+provide+safe (shift xs how-far [fill-item #f] [cycle #f]) + ((list? integer?) (any/c boolean?) . ->* . list?) (define abs-how-far (abs how-far)) - (cond - [(> abs-how-far (length xs)) (error 'shift "index is too large for list\nindex: ~a\nlist: ~v" how-far xs)] - [(= how-far 0) xs] - [(positive? how-far) - (define filler (if cycle - (take-right xs abs-how-far) - (make-list abs-how-far fill-item))) - (append filler (drop-right xs abs-how-far))] - [else ; how-far is negative - (define filler (if cycle - (take xs abs-how-far) - (make-list abs-how-far fill-item))) - (append (drop xs abs-how-far) filler)])) - -(define/typed+provide (shifts xs how-fars [fill-item #f] [cycle #f]) - (All (A) (case-> ((Listof (Option A)) (Listof Integer) -> (Listof (Listof (Option A)))) - ((Listof (Option A)) (Listof Integer) (Option A) -> (Listof (Listof (Option A)))) - ((Listof (Option A)) (Listof Integer) (Option A) Boolean -> (Listof (Listof (Option A)))))) - (map (λ:([how-far : Integer]) (shift xs how-far fill-item cycle)) how-fars)) - + (cond + [(> abs-how-far (length xs)) (error 'shift "index is too large for list\nindex: ~a\nlist: ~v" how-far xs)] + [(= how-far 0) xs] + [(positive? how-far) + (define filler (if cycle + (take-right xs abs-how-far) + (make-list abs-how-far fill-item))) + (append filler (drop-right xs abs-how-far))] + [else ; how-far is negative + (define filler (if cycle + (take xs abs-how-far) + (make-list abs-how-far fill-item))) + (append (drop xs abs-how-far) filler)])) + + +(define+provide+safe (shifts xs how-fars [fill-item #f] [cycle #f]) + ((list? integers?) (any/c boolean?) . ->* . (listof list?)) + (map (λ(how-far) (shift xs how-far fill-item cycle)) how-fars)) + + +;; todo: can this work in typed context? couldn't figure out how to polymorphically `apply values` +;; macro doesn't work either +(define+provide+safe (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f]) + ((list? (or/c integers? integer?)) (any/c boolean?) . ->* . any) + (apply values ((if (list? shift-amount-or-amounts) + shifts + shift) xs shift-amount-or-amounts fill-item cycle))) \ No newline at end of file diff --git a/sugar/main.rkt b/main.rkt similarity index 100% rename from sugar/main.rkt rename to main.rkt diff --git a/typed/sugar/misc.rkt b/misc.rkt similarity index 83% rename from typed/sugar/misc.rkt rename to misc.rkt index c08e13d..f5058a1 100644 --- a/typed/sugar/misc.rkt +++ b/misc.rkt @@ -1,8 +1,9 @@ #lang racket/base -(require typed/sugar/define) +(require "define.rkt" racket/set "coerce.rkt") -(define/typed+provide (bytecount->string bytecount) - (Nonnegative-Integer -> String) + +(define+provide+safe (bytecount->string bytecount) + (integer? . -> . string?) (define (format-with-threshold threshold suffix) ;; upconvert by factor of 100 to get two digits after decimal (format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix)) @@ -17,6 +18,4 @@ [(bytecount . >= . threshold-gigabyte) (format-with-threshold threshold-gigabyte "GB")] [(bytecount . >= . threshold-megabyte) (format-with-threshold threshold-megabyte "MB")] [(bytecount . >= . threshold-kilobyte) (format-with-threshold threshold-kilobyte "KB")] - [else (format "~a bytes" bytecount)])) - - + [else (format "~a bytes" bytecount)])) \ No newline at end of file diff --git a/sugar/scribblings/cache.scrbl b/scribblings/cache.scrbl similarity index 96% rename from sugar/scribblings/cache.scrbl rename to scribblings/cache.scrbl index bf277b6..0fcf920 100644 --- a/sugar/scribblings/cache.scrbl +++ b/scribblings/cache.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Cache} -@defmodule[#:multi (sugar/cache (submod sugar/cache safe) typed/sugar/cache)] +@defmodule[#:multi (sugar/cache (submod sugar/cache safe))] If, like Ricky Bobby and me, you want to go fast, then try using more caches. They're wicked fast. diff --git a/sugar/scribblings/coerce.scrbl b/scribblings/coerce.scrbl similarity index 93% rename from sugar/scribblings/coerce.scrbl rename to scribblings/coerce.scrbl index 87ba842..523aacc 100644 --- a/sugar/scribblings/coerce.scrbl +++ b/scribblings/coerce.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Coercion} -@defmodule[#:multi (sugar/coerce (submod sugar/coerce safe) typed/sugar/coerce)] +@defmodule[#:multi (sugar/coerce (submod sugar/coerce safe))] 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. @@ -161,7 +161,7 @@ Return @racket[#t] for all @racket[_v] except @racket[#f], which remains @racket @defproc[(listish? [v any/c]) boolean?] @defproc[(vectorish? [v any/c]) boolean?] )] -@bold{Untyped only.} Predicates that report whether @racket[_v] can be coerced to the specified type. +Predicates that report whether @racket[_v] can be coerced to the specified type. @examples[#:eval my-eval (map intish? (list 3 3.5 #\A "A" + #t)) @@ -185,7 +185,7 @@ Return @racket[#t] for all @racket[_v] except @racket[#f], which remains @racket @defproc[(coerce/boolean? [v any/c]) boolean?] @defproc[(coerce/list? [v any/c]) list?] )] -@bold{Untyped only.} 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. +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. @examples[#:eval my-eval (define/contract (add-ints x y) diff --git a/sugar/scribblings/container.scrbl b/scribblings/container.scrbl similarity index 100% rename from sugar/scribblings/container.scrbl rename to scribblings/container.scrbl diff --git a/sugar/scribblings/debug.scrbl b/scribblings/debug.scrbl similarity index 97% rename from sugar/scribblings/debug.scrbl rename to scribblings/debug.scrbl index a6999ca..83e393a 100644 --- a/sugar/scribblings/debug.scrbl +++ b/scribblings/debug.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Debug} -@defmodule[#:multi (sugar/debug (submod sugar/debug safe) typed/sugar/debug)] +@defmodule[#:multi (sugar/debug (submod sugar/debug safe))] Debugging utilities. diff --git a/sugar/scribblings/file.scrbl b/scribblings/file.scrbl similarity index 97% rename from sugar/scribblings/file.scrbl rename to scribblings/file.scrbl index 2eafea6..0b188b2 100644 --- a/sugar/scribblings/file.scrbl +++ b/scribblings/file.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{File} -@defmodule[#:multi (sugar/file (submod sugar/file safe) typed/sugar/file)] +@defmodule[#:multi (sugar/file (submod sugar/file safe))] File utilities, mostly in the realm of file extensions. These functions don't access the filesystem. diff --git a/scribblings/include.scrbl b/scribblings/include.scrbl new file mode 100644 index 0000000..83880a5 --- /dev/null +++ b/scribblings/include.scrbl @@ -0,0 +1,9 @@ +#lang scribble/manual + +@(require scribble/eval (for-label racket sugar)) + +@title{Include} +@defmodule[sugar/include] + +@defform[(include-without-lang-line path-spec)] +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). \ No newline at end of file diff --git a/sugar/scribblings/installation.scrbl b/scribblings/installation.scrbl similarity index 100% rename from sugar/scribblings/installation.scrbl rename to scribblings/installation.scrbl diff --git a/sugar/scribblings/len.scrbl b/scribblings/len.scrbl similarity index 89% rename from sugar/scribblings/len.scrbl rename to scribblings/len.scrbl index 5b75290..b042593 100644 --- a/sugar/scribblings/len.scrbl +++ b/scribblings/len.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Len} -@defmodule[#:multi (sugar/len (submod sugar/len safe) typed/sugar/len)] +@defmodule[#:multi (sugar/len (submod sugar/len safe))] @defproc[ diff --git a/sugar/scribblings/license.scrbl b/scribblings/license.scrbl similarity index 100% rename from sugar/scribblings/license.scrbl rename to scribblings/license.scrbl diff --git a/sugar/scribblings/list.scrbl b/scribblings/list.scrbl similarity index 95% rename from sugar/scribblings/list.scrbl rename to scribblings/list.scrbl index a126b29..651e689 100644 --- a/sugar/scribblings/list.scrbl +++ b/scribblings/list.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar racket/list)) @title{List} -@defmodule[#:multi (sugar/list (submod sugar/list safe) typed/sugar/list)] +@defmodule[#:multi (sugar/list (submod sugar/list safe))] @@ -227,7 +227,7 @@ Same as @racket[shift], but @racket[_how-far] is a list of integers rather than [how-far (or/c integer? (listof integer?))] [fill-item any/c #f]) any] -@bold{Untyped only.} 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. +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. @examples[#:eval my-eval (define xs (range 5)) diff --git a/sugar/scribblings/string.scrbl b/scribblings/string.scrbl similarity index 92% rename from sugar/scribblings/string.scrbl rename to scribblings/string.scrbl index 17b5725..35b37ba 100644 --- a/sugar/scribblings/string.scrbl +++ b/scribblings/string.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{String} -@defmodule[#:multi (sugar/string (submod sugar/string safe) typed/sugar/string)] +@defmodule[#:multi (sugar/string (submod sugar/string safe))] @defproc[ diff --git a/scribblings/sugar.scrbl b/scribblings/sugar.scrbl new file mode 100644 index 0000000..006d15a --- /dev/null +++ b/scribblings/sugar.scrbl @@ -0,0 +1,46 @@ +#lang scribble/manual + +@(require scribble/eval (for-label racket sugar)) + +@(define my-eval (make-base-eval)) +@(my-eval `(require sugar)) + + +@title[#:style 'toc]{Sugar} + +@author[(author+email "Matthew Butterick" "mb@mbtype.com")] + +@defmodule[#:multi (sugar (submod sugar safe))] + +A collection of small functions to help make Racket code simpler & more readable. + +Sugar can be invoked two ways: as an ordinary library, or as a library with contracts (using the @tt{safe} submodule). + + +@;local-table-of-contents[] + +@include-section["installation.scrbl"] + +@include-section["cache.scrbl"] + +@include-section["coerce.scrbl"] + +@include-section["container.scrbl"] + +@include-section["debug.scrbl"] + +@include-section["file.scrbl"] + +@include-section["include.scrbl"] + +@include-section["len.scrbl"] + +@include-section["list.scrbl"] + +@include-section["string.scrbl"] + +@include-section["xml.scrbl"] + +@include-section["license.scrbl"] + +@;index-section[] diff --git a/sugar/scribblings/xml.scrbl b/scribblings/xml.scrbl similarity index 100% rename from sugar/scribblings/xml.scrbl rename to scribblings/xml.scrbl diff --git a/typed/sugar/string.rkt b/string.rkt similarity index 61% rename from typed/sugar/string.rkt rename to string.rkt index 997454f..d9bd934 100644 --- a/typed/sugar/string.rkt +++ b/string.rkt @@ -1,21 +1,25 @@ -#lang typed/racket/base -(require typed/sugar/define "coerce.rkt") +#lang racket/base +(require "define.rkt" "coerce.rkt") + -(define/typed+provide (starts-with? str starter) - (Stringish Stringish -> Boolean) +(define+provide+safe (starts-with? str starter) + (string? string? . -> . coerce/boolean?) (let ([str (->string str)] [starter (->string starter)]) (and (<= (string-length starter) (string-length str)) (equal? (substring str 0 (string-length starter)) starter)))) -(define/typed+provide (ends-with? str ender) - (Stringish Stringish -> Boolean) + +(define+provide+safe (ends-with? str ender) + (string? string? . -> . coerce/boolean?) (let ([str (->string str)] [ender (->string ender)]) (and (<= (string-length ender) (string-length str)) (equal? (substring str (- (string-length str) (string-length ender)) (string-length str)) ender)))) -(define/typed+provide (capitalized? str) - (Stringish -> Boolean) + +(define+provide+safe (capitalized? str) + (string? . -> . coerce/boolean?) (let ([str (->string str)]) (char-upper-case? (car (string->list str))))) + diff --git a/sugar/cache.rkt b/sugar/cache.rkt deleted file mode 100644 index 628d5bd..0000000 --- a/sugar/cache.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang racket/base -(require sugar/define) -(require-via-wormhole "../typed/sugar/cache.rkt") - -(provide+safe [make-caching-proc (procedure? . -> . procedure?)] - define/caching) diff --git a/sugar/coerce-helper.rkt b/sugar/coerce-helper.rkt deleted file mode 100644 index 77272bf..0000000 --- a/sugar/coerce-helper.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket/base -;; isolate typed requires in a helper file so the untyped versions can be substituted on the untyped side -(require net/url) \ No newline at end of file diff --git a/sugar/coerce.rkt b/sugar/coerce.rkt deleted file mode 100644 index f7f3da4..0000000 --- a/sugar/coerce.rkt +++ /dev/null @@ -1,75 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base racket/syntax) sugar/define net/url) -(require-via-wormhole "../typed/sugar/coerce.rkt") - -(provide+safe [->int (any/c . -> . integer?)] - [->string (any/c . -> . string?)] - [->symbol (any/c . -> . symbol?)] - [->path (any/c . -> . path?)] - [->complete-path (any/c . -> . complete-path?)] - [->url (any/c . -> . url?)] - [->list (any/c . -> . list?)] - [->vector (any/c . -> . vector?)] - [->boolean (any/c . -> . boolean?)]) - -;; coercion contracts & *ish predicates -;; only make sense in untyped code -;; thus they are here. -(define-syntax-rule (make-blame-handler try-proc expected-sym) - (λ(b) - (λ(x) - (with-handlers ([exn:fail? (λ(e) - (raise-blame-error - b x - '(expected: "~a" given: "~e") - expected-sym x))]) - (try-proc x))))) - -(provide+safe make-coercion-contract) -(define-syntax (make-coercion-contract stx) - (syntax-case stx () - [(_ stem coerce-proc) - (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)] - [can-be-stem? (format-id stx "can-be-~a?" #'stem)]) - #'(make-contract - #:name 'coerce/stem? - #:projection (make-blame-handler coerce-proc 'can-be-stem?)))] - [(_ stem) - (with-syntax ([->stem (format-id stx "->~a" #'stem)]) - #'(make-coercion-contract stem ->stem))])) - -(define-syntax (define+provide-coercion-contract stx) - (syntax-case stx () - [(_ stem) - (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]) - #'(begin - (provide+safe coerce/stem?) - (define coerce/stem? (make-coercion-contract stem))))])) - -(define+provide-coercion-contract int) -(define+provide-coercion-contract string) -(define+provide-coercion-contract symbol) -(define+provide-coercion-contract path) -(define+provide-coercion-contract boolean) -(define+provide-coercion-contract list) - - - -(define-syntax (make-*ish-predicate stx) - (syntax-case stx () - [(_ stem) - (with-syntax ([stemish? (format-id stx "~aish?" #'stem)] - [->stem (format-id stx "->~a" #'stem)]) - #`(begin - (provide+safe stemish?) - (define (stemish? x) - (with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))])) - -(make-*ish-predicate int) -(make-*ish-predicate string) -(make-*ish-predicate symbol) -(make-*ish-predicate url) -(make-*ish-predicate complete-path) -(make-*ish-predicate path) -(make-*ish-predicate list) -(make-*ish-predicate vector) \ No newline at end of file diff --git a/sugar/file.rkt b/sugar/file.rkt deleted file mode 100644 index 586013b..0000000 --- a/sugar/file.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket/base -(require sugar/define racket/set sugar/coerce) -(require-via-wormhole "../typed/sugar/file.rkt") - -(provide+safe - [get-enclosing-dir (coerce/path? . -> . path?)] - [has-ext? (coerce/path? coerce/string? . -> . coerce/boolean?)] - [get-ext (coerce/path? . -> . (or/c #f string?))] - binary-extensions - [has-binary-ext? (coerce/path? . -> . coerce/boolean?)] - [add-ext (coerce/string? coerce/string? . -> . coerce/path?)] - [remove-ext (coerce/path? . -> . path?)] - [remove-ext* (coerce/path? . -> . path?)]) - \ No newline at end of file diff --git a/sugar/info.rkt b/sugar/info.rkt deleted file mode 100644 index 039ebee..0000000 --- a/sugar/info.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang info -(define scribblings '(("scribblings/sugar.scrbl" ()))) - -(define compile-omit-paths '("test")) \ No newline at end of file diff --git a/sugar/len.rkt b/sugar/len.rkt deleted file mode 100644 index ac8fd5f..0000000 --- a/sugar/len.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang racket/base -(require sugar/define racket/set) -(require-via-wormhole "../typed/sugar/len.rkt") - -(provide+safe [len ((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?)]) diff --git a/sugar/list-helper.rkt b/sugar/list-helper.rkt deleted file mode 100644 index 378db3f..0000000 --- a/sugar/list-helper.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang racket/base -;; isolate typed requires in a helper file so the untyped versions can be substituted on the untyped side -(require (only-in racket/list dropf dropf-right)) \ No newline at end of file diff --git a/sugar/list.rkt b/sugar/list.rkt deleted file mode 100644 index 811f01a..0000000 --- a/sugar/list.rkt +++ /dev/null @@ -1,40 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base) - racket/list racket/set racket/function sugar/define) -(require "len.rkt" "coerce.rkt") - -(require-via-wormhole "../typed/sugar/list.rkt") - -(define (list-of-lists? xs) (and (list? xs) (andmap list? xs))) -(define (index? x) (and (integer? x) (not (negative? x)))) - -(define increasing-nonnegative? (λ(xs) (apply < -1 xs))) -(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?)) - -(define (integers? x) (and (list? x) (andmap integer? x))) - -(provide+safe [trimf (list? procedure? . -> . list?)] - [slicef (list? procedure? . -> . list-of-lists?)] - [slicef-at ((list? procedure?) (boolean?) . ->* . list-of-lists?)] - [slicef-after (list? procedure? . -> . list-of-lists?)] - [slice-at ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)] - [filter-split (list? predicate/c . -> . list-of-lists?)] - [frequency-hash (list? . -> . hash?)] - [members-unique? ((or/c list? vector? string?) . -> . boolean?)] - [members-unique?/error ((or/c list? vector? string?) . -> . boolean?)] - when/splice - values->list - [sublist (list? index? index? . -> . list?)] - [break-at (list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?)] - [shift ((list? integer?) (any/c boolean?) . ->* . list?)] - [shifts ((list? integers?) (any/c boolean?) . ->* . (listof list?))] - [shift/values ((list? (or/c integers? integer?)) (any/c boolean?) . ->* . any)]) - - -;; todo: can this work in typed context? couldn't figure out how to polymorphically `apply values` -;; macro doesn't work either -(define (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f]) - (apply values ((if (list? shift-amount-or-amounts) - shifts - shift) xs shift-amount-or-amounts fill-item cycle))) - diff --git a/sugar/misc.rkt b/sugar/misc.rkt deleted file mode 100644 index 645d5f6..0000000 --- a/sugar/misc.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#lang racket/base -(require sugar/define racket/set sugar/coerce) -(require-via-wormhole "../typed/sugar/misc.rkt") - -(provide+safe [bytecount->string (integer? . -> . string?)]) \ No newline at end of file diff --git a/sugar/scribblings/include.scrbl b/sugar/scribblings/include.scrbl deleted file mode 100644 index c86e362..0000000 --- a/sugar/scribblings/include.scrbl +++ /dev/null @@ -1,11 +0,0 @@ -#lang scribble/manual - -@(require scribble/eval (for-label racket sugar)) - -@title{Include} -@defmodule[sugar/include] - -@defform[(include-without-lang-line path-spec)] -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). - -Why? So you can take the code from a working source file and recompile it under a different @tt{#lang}. Why? Well, you could take code from a @tt{#lang typed/racket} source file and recompile as @tt{#lang typed/racket/no-check}. Why? Because then you could make typed and untyped modules from the same code without the mandatory contracts imposed by @racket[require/typed]. \ No newline at end of file diff --git a/sugar/scribblings/sugar.scrbl b/sugar/scribblings/sugar.scrbl deleted file mode 100644 index b394ffc..0000000 --- a/sugar/scribblings/sugar.scrbl +++ /dev/null @@ -1,51 +0,0 @@ -#lang scribble/manual - -@(require scribble/eval (for-label racket sugar (only-in typed/racket require/typed))) - -@(define my-eval (make-base-eval)) -@(my-eval `(require sugar)) - - -@title[#:style 'toc]{Sugar} - -@author[(author+email "Matthew Butterick" "mb@mbtype.com")] - -@defmodule[#:multi (sugar (submod sugar safe) typed/sugar)] - -A collection of small functions to help make Racket code simpler & more readable. - -Sugar can be invoked three ways: as an untyped library, as an untyped library with contracts (using the @tt{safe} submodule), or as a typed library. - -A few functions are only available as untyped or typed. These exceptions are noted below. - -The typed version of Sugar is implemented ``natively'' in the sense that it is compiled separately with type annotations. It is not a @racket[require/typed] wrapper around the untyped code. This avoids the contract barrier that is otherwise automatically imposed between typed and untyped code. - -@margin-note{I explain more about this cross-compiling technique in @link["http://unitscale.com/mb/technique/dual-typed-untyped-library.html"]{Making a dual typed / untyped Racket library}.} - -@;local-table-of-contents[] - -@include-section["installation.scrbl"] - -@include-section["cache.scrbl"] - -@include-section["coerce.scrbl"] - -@include-section["container.scrbl"] - -@include-section["debug.scrbl"] - -@include-section["file.scrbl"] - -@include-section["include.scrbl"] - -@include-section["len.scrbl"] - -@include-section["list.scrbl"] - -@include-section["string.scrbl"] - -@include-section["xml.scrbl"] - -@include-section["license.scrbl"] - -@;index-section[] diff --git a/sugar/string.rkt b/sugar/string.rkt deleted file mode 100644 index 234d5da..0000000 --- a/sugar/string.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base -(require sugar/define racket/set sugar/coerce) -(require-via-wormhole "../typed/sugar/string.rkt") - -(provide+safe [starts-with? (coerce/string? coerce/string? . -> . coerce/boolean?)] - [ends-with? (coerce/string? coerce/string? . -> . coerce/boolean?)] - [capitalized? (coerce/string? . -> . coerce/boolean?)]) \ No newline at end of file diff --git a/sugar/test/source.rkt b/sugar/test/source.rkt deleted file mode 100644 index d82d324..0000000 --- a/sugar/test/source.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang typed/racket - -(define included-symbol 'bar) \ No newline at end of file diff --git a/sugar/test.rkt b/test.rkt similarity index 98% rename from sugar/test.rkt rename to test.rkt index e98b52f..6d1cc5d 100644 --- a/sugar/test.rkt +++ b/test.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (for-syntax racket/base racket/syntax)) -(require sugar/define) +(require "define.rkt") (provide+safe module-test-external module-test-internal module-test-internal+external) ;; tests using module-boundary contracts diff --git a/sugar/test/debug-meta-lang.rkt b/test/debug-meta-lang.rkt similarity index 100% rename from sugar/test/debug-meta-lang.rkt rename to test/debug-meta-lang.rkt diff --git a/sugar/test/main.rkt b/test/main.rkt similarity index 94% rename from sugar/test/main.rkt rename to test/main.rkt index cf2fe15..99d3188 100644 --- a/sugar/test/main.rkt +++ b/test/main.rkt @@ -18,25 +18,8 @@ ,@(syntax->datum #'(exprs ...))) (require ',sym2))))])) -(define-syntax (eval-as-typed stx) - (syntax-case stx () - [(_ exprs ...) - (let ([sym (generate-temporary)]) - (datum->syntax stx - `(begin - (module ,sym typed/racket - (require typed/rackunit "../../typed/sugar.rkt" typed/net/url) - ,@(syntax->datum #'(exprs ...))) - (require ',sym)) - stx))])) - -(define-syntax-rule (eval-as-typed-and-untyped exprs ...) - (begin - (eval-as-untyped exprs ...) - (eval-as-typed exprs ...))) - - -(eval-as-typed-and-untyped + +(eval-as-untyped (check-equal? (->int 42) 42) (check-equal? (->int 42.1) 42) (check-equal? (->int 42+3i) 42) @@ -185,12 +168,7 @@ (check-equal? (shifts xs '(-1 0 1) 'boing) `((1 2 3 4 boing) ,xs (boing 0 1 2 3))) (check-equal? (shifts xs '(-1 0 1) 'boing #t) `((1 2 3 4 0) ,xs (4 0 1 2 3))) (check-equal? (shift xs 5 0) (make-list 5 0)) - (check-exn exn:fail? (λ() (shift xs -10)))) - - - - -(eval-as-untyped + (check-exn exn:fail? (λ() (shift xs -10))) (check-true (urlish? (->path "/Users/MB/home.html"))) (check-true (urlish? "/Users/MB/home.html?foo=bar")) @@ -241,7 +219,6 @@ (check-true (in? "foo" (string->path "/root/foo/bar/file.txt"))) (check-false (in? "zam" (string->path "/root/foo/bar/file.txt"))) - (define xs (range 5)) (define ys (range 5)) (check-equal? (values->list (shift/values ys -1 'boing)) '(1 2 3 4 boing)) (check-equal? (values->list (shift/values ys '(-1 0 1) 'boing)) `((1 2 3 4 boing) ,xs (boing 0 1 2 3))) diff --git a/sugar/test/no-lang-line-source.txt b/test/no-lang-line-source.txt similarity index 100% rename from sugar/test/no-lang-line-source.txt rename to test/no-lang-line-source.txt diff --git a/test/source.rkt b/test/source.rkt new file mode 100644 index 0000000..fb3f434 --- /dev/null +++ b/test/source.rkt @@ -0,0 +1,3 @@ +#lang racket/base + +(define included-symbol 'bar) \ No newline at end of file diff --git a/sugar/test/test-require-modes.rkt b/test/test-require-modes.rkt similarity index 64% rename from sugar/test/test-require-modes.rkt rename to test/test-require-modes.rkt index c33f0b9..9267d8f 100644 --- a/sugar/test/test-require-modes.rkt +++ b/test/test-require-modes.rkt @@ -1,13 +1,6 @@ #lang racket/base (require rackunit) -(module trb typed/racket/base - (require typed/sugar/list typed/rackunit) - (provide (all-defined-out)) - ;; (trimf odd? '(1 2 3)) ; type error - (define foo (trimf '(1 2 3) odd?)) - (check-equal? foo '(2))) - (module rb racket/base (require (submod sugar/list safe) rackunit) (provide (all-defined-out)) @@ -22,8 +15,7 @@ (define foo (trimf '(1 2 3) odd?)) (check-equal? foo '(2))) -(require (prefix-in trb: 'trb)) (require (prefix-in rb: 'rb)) (require (prefix-in rbu: 'rbu)) -(check-true (andmap (λ(val) (equal? val '(2))) (list trb:foo rb:foo rbu:foo))) \ No newline at end of file +(check-true (andmap (λ(val) (equal? val '(2))) (list rb:foo rbu:foo))) \ No newline at end of file diff --git a/typed/sugar.rkt b/typed/sugar.rkt deleted file mode 100644 index 922e3d1..0000000 --- a/typed/sugar.rkt +++ /dev/null @@ -1,17 +0,0 @@ -#lang typed/racket/base - -(define-syntax-rule (r/p name) - (begin - (require name) - (provide (all-from-out name)))) - -(r/p "sugar/cache.rkt") -(r/p "sugar/coerce.rkt") -(r/p "sugar/debug.rkt") -(r/p "sugar/define.rkt") -(r/p "sugar/file.rkt") -(r/p "sugar/len.rkt") -(r/p "sugar/list.rkt") -(r/p "sugar/misc.rkt") -(r/p "sugar/string.rkt") -(r/p "sugar/test.rkt") \ No newline at end of file diff --git a/typed/sugar/cache.rkt b/typed/sugar/cache.rkt deleted file mode 100644 index 6d032ee..0000000 --- a/typed/sugar/cache.rkt +++ /dev/null @@ -1,16 +0,0 @@ -#lang typed/racket/base -(require (for-syntax typed/racket/base) typed/sugar/define) - -(define/typed+provide (make-caching-proc base-proc) - (All (A B) (A * -> B) -> (A * -> B)) - (let ([cache ((inst make-hash (Listof A) B))]) - (λ args - (hash-ref! cache args (λ () (apply base-proc args)))))) - -(provide define/caching) -(define-syntax (define/caching stx) - (syntax-case stx () - [(_ (name arg ... . rest-arg) body ...) - #'(define/caching name (λ(arg ... . rest-arg) body ...))] - [(_ name body ...) - #'(define name (make-caching-proc body ...))])) \ No newline at end of file diff --git a/typed/sugar/coerce-helper.rkt b/typed/sugar/coerce-helper.rkt deleted file mode 100644 index d8c2c4c..0000000 --- a/typed/sugar/coerce-helper.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang typed/racket/base -;; isolate typed requires in a helper file so the untyped versions can be substituted on the untyped side -(require typed/net/url) \ No newline at end of file diff --git a/typed/sugar/coerce.rkt b/typed/sugar/coerce.rkt deleted file mode 100644 index 73e4b0d..0000000 --- a/typed/sugar/coerce.rkt +++ /dev/null @@ -1,109 +0,0 @@ -#lang typed/racket/base -(require (for-syntax typed/racket/base racket/syntax) sugar/include) -(include-without-lang-line "coerce-helper.rkt") -(require typed/sugar/define racket/set racket/sequence "len.rkt") ; want relative path-spec for bilingual conversion - -(define-syntax-rule (make-coercion-error-handler target-format x) - (λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format)))) - - -(define-type Intable (U Number String Symbol Char Path Lengthable)) -(define/typed+provide (->int x) - (Intable -> Integer) - (with-handlers ([exn:fail? (make-coercion-error-handler 'int x)]) - (cond - [(or (integer? x) (real? x)) (assert (inexact->exact (floor x)) integer?)] - [(complex? x) (->int (real-part x))] - [(string? x) (let ([strnum (string->number x)]) - (if (real? strnum) (->int strnum) (error 'ineligible-string)))] - [(or (symbol? x) (path? x)) (->int (->string x))] - [(char? x) (char->integer x)] - [else (len x)]))) ; covers Lengthable types - - -(provide Stringish) -(define-type Stringish (U String Symbol Number Path Char Null Void SugarURL)) - - -(define/typed+provide (->string x) - (Stringish -> String) - (if (string? x) - x ; fast exit for strings - (with-handlers ([exn:fail? (make-coercion-error-handler 'string x)]) - (cond - [(or (equal? '() x) (void? x)) ""] - [(symbol? x) (symbol->string x)] - [(number? x) (number->string x)] - [(path? x) (path->string x)] - [(char? x) (format "~a" x)] - [(url? x) (url->string x)] - [else (error 'bad-type)])))) - - -;; ->symbol, ->path, and ->url are just variants on ->string -;; two advantages: return correct type, and more accurate error - -;; no need for "Symbolable" type - same as Stringable -(define/typed+provide (->symbol x) - (Stringish -> Symbol) - (if (symbol? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) - (string->symbol (->string x))))) - - -(define-type Pathish (U Stringish url)) -(provide Pathish) -(define/typed+provide (->path x) - (Pathish -> Path) - (if (path? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'path x)]) - (cond - [(url? x) (apply build-path (cast (map path/param-path (url-path x)) (List* Path-String (Listof Path-String))))] - [else (string->path (->string x))])))) - - -;; Use private name here because 'URL' identifier has been added since 6.0 -(define-type SugarURL url) -(define/typed+provide (->url x) - (Stringish -> SugarURL) - (with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) - (string->url (->string x)))) - - -(define/typed+provide (->complete-path x) - (Stringish -> Path) - (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) - (path->complete-path (->path x)))) - - -(define/typed+provide (->list x) - (Any -> (Listof Any)) - (if (list? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'list x)]) - (cond - [(string? x) (list x)] - [(vector? x) (for/list ([i (in-vector x)]) - i)] - [(set? x) (set->list x)] - ;; conditional sequencing relevant because hash also tests true for `sequence?` - [(hash? x) (hash->list x)] - [(integer? x) (list x)] ; because an integer tests #t for sequence? - [(sequence? x) (sequence->list x)] - ;[(stream? x) (stream->list x)] ;; no support for streams in TR - [else (list x)])))) - - -(define/typed+provide (->vector x) - (Any -> VectorTop) - (if (vector? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) - (list->vector (->list x))))) - - -(define/typed+provide (->boolean x) - (Any -> Boolean) - (and x #t)) \ No newline at end of file diff --git a/typed/sugar/debug.rkt b/typed/sugar/debug.rkt deleted file mode 100644 index bd5b1e2..0000000 --- a/typed/sugar/debug.rkt +++ /dev/null @@ -1,88 +0,0 @@ -#lang typed/racket/base -(require (for-syntax racket/base racket/syntax)) -(provide (all-defined-out)) - - -(define-syntax (report stx) - (syntax-case stx () - [(_ expr) #'(report expr expr)] - [(_ expr name) - #'(let ([expr-result expr]) - (eprintf "~a = ~v\n" 'name expr-result) - expr-result)])) - - -(define-syntax (report/line stx) - (syntax-case stx () - [(_ expr) #'(report/line expr expr)] - [(_ expr name) - (with-syntax ([line (syntax-line #'expr)]) - #'(let ([expr-result expr]) - (eprintf "~a = ~v on line ~v\n" 'name expr-result line) - expr-result))])) - - -(define-syntax (report/file stx) - (syntax-case stx () - [(_ expr) #'(report/file expr expr)] - [(_ expr name) - (with-syntax ([file (syntax-source #'expr)] - [line (syntax-line #'expr)]) - #'(let ([expr-result expr]) - (eprintf "~a = ~v on line ~v in \"~a\"\n" 'name expr-result line 'file) - expr-result))])) - - -(define-syntax-rule (define-multi-version multi-name name) - (define-syntax-rule (multi-name x (... ...)) - (begin (name x) (... ...)))) - -(define-multi-version report* report) -(define-multi-version report*/line report/line) -(define-multi-version report*/file report/file) - - -(define-syntax report-apply - (syntax-rules () - [(report-apply proc expr) - (let ([lst expr]) - (report (apply proc lst) (apply proc expr)) - lst)] - [(report-apply proc expr #:line) - (let ([lst expr]) - (report (apply proc lst) (apply proc expr) #:line) - lst)])) - -#| -(define-syntax (verbalize stx) - (syntax-case stx () - [(_ proc args ...) - (with-syntax ([proc-input (format-id stx "args to ~a" #'proc)]) - #'(begin - (let () (report (list args ...) proc-input) (void)) - (report (proc args ...))))])) -|# - - - - -(define-syntax-rule (repeat num expr ...) - (for/last ([i (in-range num)]) - expr ...)) - - -(define-syntax-rule (time-repeat num expr ...) - (time (repeat num expr ...))) - - -(define-syntax (time-repeat* stx) - (syntax-case stx () - [(_ num expr ...) - #'(let ([n num]) - (values (time-repeat n expr) ...))])) - - -(define-syntax (compare stx) - (syntax-case stx () - [(_ expr id id-alt ...) - #'(values expr (let ([id id-alt]) expr) ...)])) diff --git a/typed/sugar/define.rkt b/typed/sugar/define.rkt deleted file mode 100644 index 030f738..0000000 --- a/typed/sugar/define.rkt +++ /dev/null @@ -1,39 +0,0 @@ -#lang typed/racket/base/no-check -;; use of no-check is deliberate here. -;; these helper macros don't do any type checking, just rearranging -;; they can't be combined with the untyped define macros, however -;; because the -> symbol is defined differently here -(require (for-syntax typed/racket/base racket/syntax)) -(provide (all-defined-out)) - -(define-syntax (define/typed stx) - (syntax-case stx () - [(_ (proc-name arg ... . rest-arg) type-expr body ...) - #'(define/typed proc-name type-expr - (λ(arg ... . rest-arg) body ...))] - [(_ proc-name type-expr body ...) - #'(begin - (: proc-name type-expr) - (define proc-name body ...))])) - -(define-syntax (define/typed+provide stx) - (syntax-case stx () - [(_ (proc-name arg ... . rest-arg) type-expr body ...) - #'(begin - (provide proc-name) - (define/typed proc-name type-expr - (λ(arg ... . rest-arg) body ...)))] - [(_ proc-name type-expr body ...) - #'(begin - (provide proc-name) - (begin - (: proc-name : type-expr) - (define proc-name body ...)))])) - -(define-syntax (define-type+predicate stx) - (syntax-case stx () - [(_ id basetype) - (with-syntax ([id? (format-id stx "~a?" #'id)]) - #'(begin - (define-type id basetype) - (define-predicate id? id)))])) \ No newline at end of file diff --git a/typed/sugar/len.rkt b/typed/sugar/len.rkt deleted file mode 100644 index 39dba1f..0000000 --- a/typed/sugar/len.rkt +++ /dev/null @@ -1,19 +0,0 @@ -#lang typed/racket/base -(require racket/set racket/sequence) -(require typed/sugar/define) - -(provide Lengthable) -(define-type Lengthable (U (Listof Any) String Symbol Path (Vectorof Any) HashTableTop (Setof Any))) - -(define/typed+provide (len x) - (Lengthable -> Nonnegative-Integer) - (cond - [(list? x) (length x)] - [(string? x) (string-length x)] - [(symbol? x) (len (symbol->string x))] - [(path? x) (len (path->string x))] - [(vector? x) (vector-length x)] - [(hash? x) (len (hash-keys x))] - [(set? x) (len (set->list x))] - [(and (sequence? x) (not (integer? x))) (len (sequence->list x))] - [else (error "len: can't calculate length of" x)])) \ No newline at end of file diff --git a/typed/sugar/list-helper.rkt b/typed/sugar/list-helper.rkt deleted file mode 100644 index 8dde5f7..0000000 --- a/typed/sugar/list-helper.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang typed/racket/base -;; isolate typed requires in a helper file so the untyped versions can be substituted on the untyped side -(require/typed racket/list [dropf (All (A) (Listof A) (A -> Boolean) -> (Listof A))] - [dropf-right (All (A) (Listof A) (A -> Boolean) -> (Listof A))]) \ No newline at end of file diff --git a/typed/sugar/test.rkt b/typed/sugar/test.rkt deleted file mode 100644 index 63e027d..0000000 --- a/typed/sugar/test.rkt +++ /dev/null @@ -1,22 +0,0 @@ -#lang typed/racket/base/no-check -(require (for-syntax typed/racket/base) typed/rackunit) - -(provide check-typing-fails check-typing) - -(define-syntax (check-typing-base stx) - (syntax-case stx () - [(_ wants-to-fail? expr) - (let* ([wants-to-fail? (syntax->datum #'wants-to-fail?)] - [λ-arg 'v] - [eval-string (if wants-to-fail? `(cons '#%top-interaction ,λ-arg) λ-arg)] - [check-string (if wants-to-fail? '(curry check-exn exn:fail:syntax?) 'check-not-exn)]) - #`(begin - (define-namespace-anchor ns) - (let ([E (λ(#,λ-arg) (eval #,eval-string (namespace-anchor->namespace ns)))]) - (apply #,check-string (list (λ _ (call-with-values (λ _ (E 'expr)) (λ vals (car vals)))))))))])) - -(define-syntax-rule (check-typing-fails expr) - (check-typing-base #t expr)) - -(define-syntax-rule (check-typing expr) - (check-typing-base #f expr)) diff --git a/typed/sugar/xml.rkt b/typed/sugar/xml.rkt deleted file mode 100644 index 9fb2f31..0000000 --- a/typed/sugar/xml.rkt +++ /dev/null @@ -1,45 +0,0 @@ -#lang typed/racket/base -(require racket/port) -#;(provide (all-defined-out)) -#;(require/typed xml [permissive-xexprs (Parameterof Boolean)] - [#:struct prolog ([misc : (Listof Misc)][dtd : (Option DTD)][misc2 : (Listof Misc)])] - [#:struct document ([prolog : Prolog][element : Element][misc : (Listof Misc)])]) - -#| -The following grammar describes expressions that create X-expressions: - - xexpr = string - | (list symbol (list (list symbol string) ...) xexpr ...) - | (cons symbol (list xexpr ...)) - | symbol - | valid-char? - | cdata - | misc -|# - -(define-type Cdata String) ;; could be tighter - -;; valid-char could be tighter -#| -Returns true if x is an exact-nonnegative-integer whose character interpretation under UTF-8 is from the set ([#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]), -|# -(define-type Valid-Char Char) -(define-type Xexpr (Rec X (U String - (List* Symbol (Listof (List Symbol String)) (Listof X)) - (Pairof Symbol (Listof X)) - Symbol - Valid-Char - Cdata))) -(define-predicate Xexpr? Xexpr) - -#| -(: xml-string->xexprs (String . -> . (values Xexpr Xexpr))) -(define (xml-string->xexprs str) - (define xml-doc (with-input-from-string str (λ _ (permissive-xexprs #t) (read-xml)))) - (values (xml->xexpr (document-prolog xml-doc)) (xml->xexpr (document-element xml-doc)))) - - -(define (xexprs->xml-string prolog-xexpr root-xexpr) - (xexpr? xexpr? . -> . string?) - (with-output-to-string (λ _ (write-xml (document (xexpr->xml prolog-xexpr) (xexpr->xml root-xexpr) null))))) -|# \ No newline at end of file diff --git a/sugar/xml.rkt b/xml.rkt similarity index 100% rename from sugar/xml.rkt rename to xml.rkt