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

@ -15,8 +15,4 @@ In safe mode (with contracts):
(require (submod sugar safe)) (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). 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 #lang racket/base
(require sugar/define) (require (for-syntax racket/base racket/syntax) "define.rkt")
(require-via-wormhole "../typed/sugar/debug.rkt")
(provide+safe report report/line report/file (provide+safe report report/line report/file
report* report*/line report*/file report* report*/line report*/file
report-apply repeat time-repeat time-repeat* compare) 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 (module reader racket/base
(require syntax/module-reader racket/syntax version/utils) (require syntax/module-reader racket/syntax version/utils)
(provide (rename-out [debug-read read] (provide (rename-out [debug-read read]

@ -1,43 +1,48 @@
#lang typed/racket/base #lang racket/base
(require typed/sugar/define "coerce.rkt" "string.rkt" racket/path) (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))) (simplify-path (build-path (->path p) 'up)))
;; does path have a certain extension ;; does path have a certain extension
(define/typed+provide (has-ext? x ext) (define+provide+safe (has-ext? x ext)
(Pathish Stringish -> Boolean) (coerce/path? coerce/string? . -> . coerce/boolean?)
(define ext-of-path (filename-extension (->path x))) (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)))))) (->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 ;; get file extension as a string, or return #f
;; (consistent with filename-extension behavior) ;; (consistent with filename-extension behavior)
(define/typed+provide (get-ext x) (define+provide+safe (get-ext x)
(Pathish -> (Option String)) (coerce/path? . -> . (or/c #f string?))
(let ([fe-result (filename-extension (->path x))]) (let ([fe-result (filename-extension (->path x))])
(and fe-result (bytes->string/utf-8 fe-result)))) (and fe-result (bytes->string/utf-8 fe-result))))
;; todo: add extensions ;; todo: add extensions
(define/typed+provide binary-extensions (provide+safe binary-extensions)
(Listof String) (define binary-extensions
(map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe))) (map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe)))
(define/typed+provide (has-binary-ext? x)
(Pathish -> Boolean) (define+provide+safe (has-binary-ext? x)
(coerce/path? . -> . coerce/boolean?)
(let ([x (->path x)]) (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 ;; put extension on path
;; use local contract here because this function is used within module ;; use local contract here because this function is used within module
(define/typed+provide (add-ext x ext) (define+provide+safe (add-ext x ext)
(Stringish Stringish -> Path) (coerce/string? coerce/string? . -> . coerce/path?)
(->path (string-append (->string x) "." (->string ext)))) (->path (string-append (->string x) "." (->string ext))))
;; take one extension off path ;; take one extension off path
(define/typed+provide (remove-ext x) (define+provide+safe (remove-ext x)
(Pathish -> Path) (coerce/path? . -> . path?)
;; pass through hidden files (those starting with a dot) ;; pass through hidden files (those starting with a dot)
(let ([x (->path x)]) (let ([x (->path x)])
(if (x . starts-with? . ".") (if (x . starts-with? . ".")
@ -46,8 +51,8 @@
;; take all extensions off path ;; take all extensions off path
(define/typed+provide (remove-ext* x) (define+provide+safe (remove-ext* x)
(Pathish -> Path) (coerce/path? . -> . path?)
;; pass through hidden files (those starting with a dot) ;; pass through hidden files (those starting with a dot)
(let ([x (->path x)]) (let ([x (->path x)])
(if (x . starts-with? . ".") (if (x . starts-with? . ".")
@ -56,4 +61,3 @@
(if (equal? x path-with-removed-ext) (if (equal? x path-with-removed-ext)
x x
(remove-ext* path-with-removed-ext)))))) (remove-ext* path-with-removed-ext))))))

@ -1,11 +1,10 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
syntax/path-spec syntax/path-spec
racket/private/increader racket/private/increader
compiler/cm-accomplice compiler/cm-accomplice
racket/match racket/function) racket/match racket/function)
sugar/define) "define.rkt")
(provide+safe include-without-lang-line) (provide+safe include-without-lang-line)

@ -1,7 +1,6 @@
#lang info #lang info
(define collection 'multi) (define collection "sugar")
(define deps '("base" (define deps '("base" "rackunit-lib"))
"typed-racket-lib" (define build-deps '("scribble-lib" "racket-doc"))
"typed-racket-more" (define scribblings '(("scribblings/sugar.scrbl" ())))
"rackunit-lib")) (define compile-omit-paths '("test"))
(define build-deps '("scribble-lib" "racket-doc" "typed-racket-doc"))

@ -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 #lang racket/base
(require (for-syntax racket/base racket/syntax) racket/function sugar/include) (require (for-syntax racket/base) racket/list racket/set racket/function)
(require (except-in racket/list dropf dropf-right) typed/sugar/define "coerce.rkt" "len.rkt") (require "len.rkt" "coerce.rkt" "define.rkt")
(include-without-lang-line "list-helper.rkt")
;; use fully-qualified paths in require, (define (list-of-lists? xs) (and (list? xs) (andmap list? xs)))
;; so they'll work when this file is included elsewhere (define (index? x) (and (integer? x) (not (negative? x))))
(provide (all-defined-out))
(define increasing-nonnegative? (λ(xs) (apply < -1 xs)))
(define/typed+provide (trimf xs test-proc) (define increasing-nonnegative-list? (and/c list? increasing-nonnegative?))
(All (A) ((Listof A) (A -> Boolean) -> (Listof A)))
(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)) (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) (define-values (last-list list-of-lists last-negating)
(for/fold: ([current-list : (Listof A) empty] (for/fold ([current-list empty]
[list-of-lists : (Listof (Listof A)) empty] [list-of-lists empty]
[negating? : Boolean #f]) [negating? #f])
([x (in-list xs)]) ([x (in-list xs)])
(define current-pred (if negating? (λ: ([x : A]) (not (pred x))) pred)) (define current-pred (if negating? (λ (x) (not (pred x))) pred))
(if (current-pred x) (if (current-pred x)
(values (cons x current-list) list-of-lists negating?) (values (cons x current-list) list-of-lists negating?)
(values (cons x null) (if (not (empty? current-list)) (values (cons x null) (if (not (empty? current-list))
@ -26,14 +32,13 @@
(reverse (cons (reverse last-list) list-of-lists))) (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 ;; with polymorphic function, use cased typing to simulate optional position arguments
(All (A) (case-> ((Listof A) (A -> Boolean) -> (Listof (Listof A))) ((list? procedure?) (boolean?) . ->* . list-of-lists?)
((Listof A) (A -> Boolean) Boolean -> (Listof (Listof A)))))
(define-values (last-list list-of-lists) (define-values (last-list list-of-lists)
(for/fold: (for/fold
([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) ([current-list empty][list-of-lists empty])
([x (in-list xs)]) ([x (in-list xs)])
(if (pred x) (if (pred x)
(values (cons x null) (if (not (empty? current-list)) (values (cons x null) (if (not (empty? current-list))
(cons (reverse current-list) list-of-lists) (cons (reverse current-list) list-of-lists)
@ -46,11 +51,12 @@
(cdr list-of-lists) (cdr list-of-lists)
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) (define-values (last-list list-of-lists)
(for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) (for/fold ([current-list empty][list-of-lists empty])
([x (in-list xs)]) ([x (in-list xs)])
(if (pred x) (if (pred x)
(values empty (cons (reverse (cons x current-list)) list-of-lists)) (values empty (cons (reverse (cons x current-list)) list-of-lists))
(values (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)))) (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 ;; with polymorphic function, use cased typing to simulate optional position arguments
(All (A) (case-> ((Listof A) Positive-Integer -> (Listof (Listof A))) ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)
((Listof A) Positive-Integer Boolean -> (Listof (Listof A)))))
(define-values (last-list list-of-lists) (define-values (last-list list-of-lists)
(for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) (for/fold ([current-list empty][list-of-lists empty])
([x (in-list xs)][i (in-naturals)]) ([x (in-list xs)][i (in-naturals)])
(if (= (modulo (add1 i) len) 0) (if (= (modulo (add1 i) len) 0)
(values empty (cons (reverse (cons x current-list)) list-of-lists)) (values empty (cons (reverse (cons x current-list)) list-of-lists))
(values (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)))) (cons (reverse last-list) list-of-lists))))
(define/typed+provide (filter-split xs pred) (define+provide+safe (filter-split xs pred)
(All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A)))) (list? predicate/c . -> . list-of-lists?)
(define-values (last-list list-of-lists) (define-values (last-list list-of-lists)
(for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) (for/fold ([current-list empty][list-of-lists empty])
([x (in-list xs)]) ([x (in-list xs)])
(if (pred x) (if (pred x)
(values empty (if (not (empty? current-list)) (values empty (if (not (empty? current-list))
(cons (reverse current-list) list-of-lists) (cons (reverse current-list) list-of-lists)
@ -88,17 +93,17 @@
(cons (reverse last-list) list-of-lists) (cons (reverse last-list) list-of-lists)
list-of-lists))) list-of-lists)))
(define/typed+provide (frequency-hash xs)
(All (A) ((Listof A) -> (HashTable A Integer))) (define+provide+safe (frequency-hash xs)
(define counter ((inst make-hash A Integer))) (list? . -> . hash?)
(define counter (make-hash))
(for ([item (in-list xs)]) (for ([item (in-list xs)])
(hash-update! counter item (λ:([v : Integer]) (add1 v)) (λ _ 0))) (hash-update! counter item (λ(v) (add1 v)) (λ _ 0)))
counter) counter)
(define+provide+safe (members-unique? x)
(define/typed+provide (members-unique? x) ((or/c list? vector? string?) . -> . boolean?)
(All (A) ((U (Listof A) (Vectorof A) String) -> Boolean))
(cond (cond
[(list? x) (= (len (remove-duplicates x)) (len x))] [(list? x) (= (len (remove-duplicates x)) (len x))]
[(vector? x) (members-unique? (->list x))] [(vector? x) (members-unique? (->list x))]
@ -106,12 +111,12 @@
[else (error (format "members-unique? cannot be determined for ~a" x))])) [else (error (format "members-unique? cannot be determined for ~a" x))]))
(define/typed+provide (members-unique?/error x) (define+provide+safe (members-unique?/error x)
(All (A) ((U (Listof A) (Vectorof A) String) -> Boolean)) ((or/c list? vector? string?) . -> . boolean?)
(define result (members-unique? x)) (define result (members-unique? x))
(if (not result) (if (not result)
(let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x)) (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) (error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1)
"item isnt" "item isnt"
"items arent") " unique:") duplicate-keys)) "items arent") " unique:") duplicate-keys))
@ -121,30 +126,31 @@
;; for use inside quasiquote ;; for use inside quasiquote
;; instead of ,(when ...) use ,@(when/splice ...) ;; instead of ,(when ...) use ,@(when/splice ...)
;; to avoid voids ;; to avoid voids
(provide when/splice) (provide+safe when/splice)
(define-syntax (when/splice stx) (define-syntax (when/splice stx)
(syntax-case stx () (syntax-case stx ()
[(_ test body) [(_ test body)
#'(if test (list body) '())])) #'(if test (list body) '())]))
(provide values->list)
(provide+safe values->list)
(define-syntax (values->list stx) (define-syntax (values->list stx)
(syntax-case stx () (syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)])) [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
(define/typed+provide (sublist xs i j) (define+provide+safe (sublist xs i j)
(All (A) ((Listof A) Index Index -> (Listof A))) (list? index? index? . -> . list?)
(cond (cond
[(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))] [(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))]
[(>= j i) (take (drop xs i) (- j i))] [(>= j i) (take (drop xs i) (- j i))]
[else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))])) [else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))]))
(define/typed+provide (break-at xs bps) (define+provide+safe (break-at xs bps)
(All (A) ((Listof A) (U Nonnegative-Integer (Listof Nonnegative-Integer)) -> (Listof (Listof A)))) (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 (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)))) (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 ;; easier to do back to front, because then the list index for each item won't change during the recursion
;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition ;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition
@ -156,28 +162,33 @@
(cons tail (loop head (cdr bps))))))))) (cons tail (loop head (cdr bps)))))))))
(define/typed+provide (shift xs how-far [fill-item #f] [cycle #f]) (define+provide+safe (shift xs how-far [fill-item #f] [cycle #f])
(All (A) (case-> ((Listof (Option A)) Integer -> (Listof (Option A))) ((list? integer?) (any/c boolean?) . ->* . list?)
((Listof (Option A)) Integer (Option A) -> (Listof (Option A)))
((Listof (Option A)) Integer (Option A) Boolean -> (Listof (Option A)))))
(define abs-how-far (abs how-far)) (define abs-how-far (abs how-far))
(cond (cond
[(> abs-how-far (length xs)) (error 'shift "index is too large for list\nindex: ~a\nlist: ~v" how-far xs)] [(> abs-how-far (length xs)) (error 'shift "index is too large for list\nindex: ~a\nlist: ~v" how-far xs)]
[(= how-far 0) xs] [(= how-far 0) xs]
[(positive? how-far) [(positive? how-far)
(define filler (if cycle (define filler (if cycle
(take-right xs abs-how-far) (take-right xs abs-how-far)
(make-list abs-how-far fill-item))) (make-list abs-how-far fill-item)))
(append filler (drop-right xs abs-how-far))] (append filler (drop-right xs abs-how-far))]
[else ; how-far is negative [else ; how-far is negative
(define filler (if cycle (define filler (if cycle
(take xs abs-how-far) (take xs abs-how-far)
(make-list abs-how-far fill-item))) (make-list abs-how-far fill-item)))
(append (drop xs abs-how-far) filler)])) (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)))) (define+provide+safe (shifts xs how-fars [fill-item #f] [cycle #f])
((Listof (Option A)) (Listof Integer) (Option A) -> (Listof (Listof (Option A)))) ((list? integers?) (any/c boolean?) . ->* . (listof list?))
((Listof (Option A)) (Listof Integer) (Option A) Boolean -> (Listof (Listof (Option A)))))) (map (λ(how-far) (shift xs how-far fill-item cycle)) how-fars))
(map (λ:([how-far : Integer]) (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 #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) (define (format-with-threshold threshold suffix)
;; upconvert by factor of 100 to get two digits after decimal ;; upconvert by factor of 100 to get two digits after decimal
(format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix)) (format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix))
@ -18,5 +19,3 @@
[(bytecount . >= . threshold-megabyte) (format-with-threshold threshold-megabyte "MB")] [(bytecount . >= . threshold-megabyte) (format-with-threshold threshold-megabyte "MB")]
[(bytecount . >= . threshold-kilobyte) (format-with-threshold threshold-kilobyte "KB")] [(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)) @(my-eval `(require sugar))
@title{Cache} @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. 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)) @(my-eval `(require sugar))
@title{Coercion} @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. 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[(listish? [v any/c]) boolean?]
@defproc[(vectorish? [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 @examples[#:eval my-eval
(map intish? (list 3 3.5 #\A "A" + #t)) (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/boolean? [v any/c]) boolean?]
@defproc[(coerce/list? [v any/c]) list?] @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 @examples[#:eval my-eval
(define/contract (add-ints x y) (define/contract (add-ints x y)

@ -6,7 +6,7 @@
@(my-eval `(require sugar)) @(my-eval `(require sugar))
@title{Debug} @title{Debug}
@defmodule[#:multi (sugar/debug (submod sugar/debug safe) typed/sugar/debug)] @defmodule[#:multi (sugar/debug (submod sugar/debug safe))]
Debugging utilities. Debugging utilities.

@ -6,7 +6,7 @@
@(my-eval `(require sugar)) @(my-eval `(require sugar))
@title{File} @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. 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)) @(my-eval `(require sugar))
@title{Len} @title{Len}
@defmodule[#:multi (sugar/len (submod sugar/len safe) typed/sugar/len)] @defmodule[#:multi (sugar/len (submod sugar/len safe))]
@defproc[ @defproc[

@ -6,7 +6,7 @@
@(my-eval `(require sugar racket/list)) @(my-eval `(require sugar racket/list))
@title{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?))] [how-far (or/c integer? (listof integer?))]
[fill-item any/c #f]) [fill-item any/c #f])
any] 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 @examples[#:eval my-eval
(define xs (range 5)) (define xs (range 5))

@ -6,7 +6,7 @@
@(my-eval `(require sugar)) @(my-eval `(require sugar))
@title{String} @title{String}
@defmodule[#:multi (sugar/string (submod sugar/string safe) typed/sugar/string)] @defmodule[#:multi (sugar/string (submod sugar/string safe))]
@defproc[ @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 #lang racket/base
(require typed/sugar/define "coerce.rkt") (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)] (let ([str (->string str)]
[starter (->string starter)]) [starter (->string starter)])
(and (<= (string-length starter) (string-length str)) (and (<= (string-length starter) (string-length str))
(equal? (substring str 0 (string-length starter)) starter)))) (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)] (let ([str (->string str)]
[ender (->string ender)]) [ender (->string ender)])
(and (<= (string-length ender) (string-length str)) (and (<= (string-length ender) (string-length str))
(equal? (substring str (- (string-length str) (string-length ender)) (string-length str)) ender)))) (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)]) (let ([str (->string str)])
(char-upper-case? (car (string->list 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 #lang racket/base
(require (for-syntax racket/base racket/syntax)) (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) (provide+safe module-test-external module-test-internal module-test-internal+external)
;; tests using module-boundary contracts ;; tests using module-boundary contracts

@ -18,25 +18,8 @@
,@(syntax->datum #'(exprs ...))) ,@(syntax->datum #'(exprs ...)))
(require ',sym2))))])) (require ',sym2))))]))
(define-syntax (eval-as-typed stx)
(syntax-case stx () (eval-as-untyped
[(_ 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
(check-equal? (->int 42) 42) (check-equal? (->int 42) 42)
(check-equal? (->int 42.1) 42) (check-equal? (->int 42.1) 42)
(check-equal? (->int 42+3i) 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) `((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? (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-equal? (shift xs 5 0) (make-list 5 0))
(check-exn exn:fail? (λ() (shift xs -10)))) (check-exn exn:fail? (λ() (shift xs -10)))
(eval-as-untyped
(check-true (urlish? (->path "/Users/MB/home.html"))) (check-true (urlish? (->path "/Users/MB/home.html")))
(check-true (urlish? "/Users/MB/home.html?foo=bar")) (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-true (in? "foo" (string->path "/root/foo/bar/file.txt")))
(check-false (in? "zam" (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)) (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 '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))) (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 #lang racket/base
(require rackunit) (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 (module rb racket/base
(require (submod sugar/list safe) rackunit) (require (submod sugar/list safe) rackunit)
(provide (all-defined-out)) (provide (all-defined-out))
@ -22,8 +15,7 @@
(define foo (trimf '(1 2 3) odd?)) (define foo (trimf '(1 2 3) odd?))
(check-equal? foo '(2))) (check-equal? foo '(2)))
(require (prefix-in trb: 'trb))
(require (prefix-in rb: 'rb)) (require (prefix-in rb: 'rb))
(require (prefix-in rbu: 'rbu)) (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