dev-fixit
Matthew Butterick 9 years ago
parent 37f923be8d
commit 809b7435b7

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

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

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

@ -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]

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

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

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

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

@ -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 isnt"
"items arent") " 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)))

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

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

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

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

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

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

@ -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[

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

@ -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[

@ -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[]

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

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

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

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

@ -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?)])

@ -1,4 +0,0 @@
#lang info
(define scribblings '(("scribblings/sugar.scrbl" ())))
(define compile-omit-paths '("test"))

@ -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?)])

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

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

@ -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?)])

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

@ -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[]

@ -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?)])

@ -1,3 +0,0 @@
#lang typed/racket
(define included-symbol 'bar)

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

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

@ -0,0 +1,3 @@
#lang racket/base
(define included-symbol 'bar)

@ -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)))
(check-true (andmap (λ(val) (equal? val '(2))) (list rb:foo rbu:foo)))

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

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

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

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

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

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

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

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

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

@ -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)))))
|#
Loading…
Cancel
Save