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

add typed/sugar

Browse Source
pull/2/head
Matthew Butterick 9 years ago
parent 9136e061b6
commit e34c67adc2
55 changed files with 1111 additions and 552 deletions
Show Stats Download Patch File Download Diff File

8
.gitignore vendored
Unescape Escape View File

@ -15,7 +15,7 @@ Icon
.Trashes
# generated documentation
doc/*
scribblings/*.js
scribblings/*.css
scribblings/*.html
sugar/doc/*
sugar/scribblings/*.js
sugar/scribblings/*.css
sugar/scribblings/*.html

16
cache.rkt
Unescape Escape View File

@ -1,16 +0,0 @@
#lang racket/base
(require (for-syntax racket/base) racket/contract)
(provide (all-defined-out))
(define/contract (make-caching-proc base-proc)
(procedure? . -> . procedure?)
(let ([cache (make-hash)])
(λ args
(hash-ref! cache args (λ () (apply base-proc args))))))
(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 ...))]))

156
coerce.rkt
Unescape Escape View File

@ -1,156 +0,0 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax))
(require net/url racket/set racket/contract racket/sequence racket/stream racket/dict)
(require "len.rkt" "define.rkt")
(define (make-coercion-error-handler target-format x)
(λ(e) (error (format "Can’t convert ~a to ~a" x target-format))))
(define+provide (->int x)
(with-handlers ([exn:fail? (make-coercion-error-handler 'integer x)])
(cond
[(or (integer? x) (real? x)) (inexact->exact (floor x))]
[(and (string? x) (> (len x) 0)) (->int (string->number x))]
[(symbol? x) (->int (->string x))]
[(char? x) (char->integer x)]
[(path? x) (->int (->string x))]
[else (len x)])))
(provide ->macrostring)
(define-syntax-rule (->macrostring x)
(if (string? x)
x ; fast exit for strings
(with-handlers ([exn:fail? (make-coercion-error-handler 'string (format "~a (result of ~a" x '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)]
[else (error)]))))
(define+provide (->string x)
(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)]
[else (error)]))))
(define+provide (->symbol x)
(if (symbol? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)])
(string->symbol (->string x)))))
(define+provide (->path x)
(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 (->url x)
(with-handlers ([exn:fail? (make-coercion-error-handler 'url x)])
(string->url (->string x))))
(define+provide (->complete-path x)
(with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)])
(path->complete-path (->path x))))
(define+provide (->list x)
(if (list? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'list x)])
(cond
[(string? x) (list x)]
[(vector? x) (vector->list x)]
[(set? x) (set->list x)]
;; location relevant because hash or dict are also sequences
[(dict? x) (dict->list x)]
[(integer? x) (list x)] ; because an integer tests #t for sequence?
[(sequence? x) (sequence->list x)]
[(stream? x) (stream->list x)]
[else (list x)]))))
(define+provide (->vector x)
(if (vector? x)
x
(with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)])
(list->vector (->list x)))))
(define+provide (->boolean x)
(and x #t))
(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
(define+provide (stemish? x)
(with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))]))
(make-*ish-predicate int)
(make-*ish-predicate string)
(make-*ish-predicate symbol)
(make-*ish-predicate url)
(make-*ish-predicate complete-path)
(make-*ish-predicate path)
(make-*ish-predicate list)
(make-*ish-predicate vector)
;; no point to having list and vector here; they work with everything
(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 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)])
#'(define+provide 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)

52
define.rkt
Unescape Escape View File

@ -1,52 +0,0 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/contract)
(provide (all-defined-out) (all-from-out racket/contract))
;; each define macro recursively converts any form of define
;; into its lambda form (define name body ...) and then operates on that.
(define-syntax (define+provide+safe stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide+safe proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(define name body ...)
(provide name)
(module+ safe
(provide (contract-out [name contract]))))]))
(define-syntax (define+provide/contract stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide/contract proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide (contract-out [name contract]))
(define name body ...))]))
(define-syntax (define/contract+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define/contract+provide proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide name)
(define/contract name contract body ...))]))
(define-syntax (define+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) body ...)
#'(define+provide proc
(λ(arg ... . rest-arg) body ...))]
[(_ name body ...)
#'(begin
(provide name)
(define name body ...))]))

55
file.rkt
Unescape Escape View File

@ -1,55 +0,0 @@
#lang racket/base
(require "define.rkt" "coerce.rkt" "string.rkt" racket/path)
(define+provide/contract (get-enclosing-dir p)
(coerce/path? . -> . path?)
(simplify-path (build-path p 'up)))
;; does path have a certain extension
(define+provide/contract (has-ext? x ext)
(coerce/path? coerce/string? . -> . coerce/boolean?)
(define ext-of-path (filename-extension x))
(and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase ext))))
;; get file extension as a string, or return #f
;; (consistent with filename-extension behavior)
(define+provide/contract (get-ext x)
(coerce/path? . -> . (or/c #f string?))
(let ([fe-result (filename-extension x)])
(and fe-result (bytes->string/utf-8 fe-result))))
;; todo: add extensions
(define binary-extensions
(map ->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe)))
(define+provide/contract (has-binary-ext? x)
(coerce/path? . -> . coerce/boolean?)
(ormap (λ(ext) (has-ext? x ext)) binary-extensions))
;; put extension on path
;; use local contract here because this function is used within module
(define/contract+provide (add-ext x ext)
(coerce/string? coerce/string? . -> . coerce/path?)
(string-append x "." ext))
;; take one extension off path
(define+provide/contract (remove-ext x)
(coerce/path? . -> . path?)
;; pass through hidden files (those starting with a dot)
(if (x . starts-with? . ".")
x
(path-replace-suffix x "")))
;; take all extensions off path
(define+provide/contract (remove-ext* x)
(coerce/path? . -> . path?)
;; pass through hidden files (those starting with a dot)
(if (x . starts-with? . ".")
x
(let ([path-with-removed-ext (remove-ext x)])
(if (equal? x path-with-removed-ext)
x
(remove-ext* path-with-removed-ext)))))

10
info.rkt
Unescape Escape View File

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

165
list.rkt
Unescape Escape View File

@ -1,165 +0,0 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/list racket/set racket/function)
(require "define.rkt" "len.rkt" "coerce.rkt")
(define+provide/contract (trimf xs test-proc)
(list? procedure? . -> . list?)
(dropf-right (dropf xs test-proc) test-proc))
(define (list-of-lists? xs) (and (list? xs) (andmap list? xs)))
(define+provide/contract (slicef-at xs pred [force? #f])
((list? procedure?) (boolean?) . ->* . list-of-lists?)
(define-values (last-list list-of-lists)
(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)
list-of-lists))
(values (cons x current-list) list-of-lists))))
(let ([list-of-lists (reverse (if (empty? last-list)
list-of-lists
(cons (reverse last-list) list-of-lists)))])
(if (and force? (not (empty? list-of-lists)) (not (pred (caar list-of-lists))))
(cdr list-of-lists)
list-of-lists)))
(define+provide/contract (slicef-after xs pred)
(list? procedure? . -> . list-of-lists?)
(define-values (last-list list-of-lists)
(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))))
(reverse (if (empty? last-list)
list-of-lists
(cons (reverse last-list) list-of-lists))))
(define+provide/contract (slice-at xs len [force? #f])
((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)
(define-values (last-list list-of-lists)
(for/fold ([current-list empty][list-of-lists empty])([(x i) (in-indexed xs)])
(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))))
(reverse (if (or (empty? last-list) (and force? (not (= len (length last-list)))))
list-of-lists
(cons (reverse last-list) list-of-lists))))
(define+provide/contract (filter-split xs pred)
(list? predicate/c . -> . list-of-lists?)
(define-values (last-list list-of-lists)
(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)
list-of-lists))
(values (cons x current-list) list-of-lists))))
(reverse (if (not (empty? last-list))
(cons (reverse last-list) list-of-lists)
list-of-lists)))
(define+provide/contract (frequency-hash x)
(list? . -> . hash?)
(define counter (make-hash))
(for ([item (in-list (flatten x))])
(hash-set! counter item (add1 (hash-ref counter item 0))))
counter)
(define+provide/contract (members-unique? x)
((or/c list? vector? string?) . -> . boolean?)
(cond
[(list? x) (= (len (remove-duplicates x)) (len x))]
[(vector? x) (->list x)]
[(string? x) (string->list x)]
[else (error (format "members-unique? cannot be determined for ~a" x))]))
(define+provide/contract (members-unique?/error x)
(any/c . -> . boolean?)
(define result (members-unique? x))
(if (not result)
(let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash x)
(λ(k v) (if (> v 1) k '()))))])
(error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1)
"item isn’t"
"items aren’t") " unique:") duplicate-keys))
result))
;; for use inside quasiquote
;; instead of ,(when ...) use ,@(when/splice ...)
;; to avoid voids
(provide when/splice)
(define-syntax (when/splice stx)
(syntax-case stx ()
[(_ test body)
#'(if test (list body) '())]))
(provide values->list)
(define-syntax (values->list stx)
(syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
(define+provide/contract (sublist xs i j)
(list? (and/c integer? (not/c negative?)) (and/c integer? (not/c negative?)) . -> . 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 increasing-nonnegative? (λ(xs) (apply < -1 xs)))
(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?))
(define+provide/contract (break-at xs bps)
(list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?)
(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
;; because breaking at zero means we've reached the start of the list
(reverse (let loop ([xs xs][bps (reverse (cons 0 bps))])
(if (= (car bps) 0)
(cons xs null) ; return whatever's left, because no more splits are possible
(let-values ([(head tail) (split-at xs (car bps))])
(cons tail (loop head (cdr bps))))))))
(define (integers? x)
(and (list? x) (andmap integer? x)))
(define+provide/contract (shift xs shift-amount-or-amounts [fill-item #f] [cycle? #f])
((list? (or/c integer? integers?)) (any/c boolean?) . ->* . list?)
(define (do-shift xs how-far)
(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) (append (make-list abs-how-far fill-item) (drop-right xs abs-how-far))]
;; otherwise how-far is negative
[else (append (drop xs abs-how-far) (make-list abs-how-far fill-item))]))
(if (list? shift-amount-or-amounts)
(map (curry do-shift xs) shift-amount-or-amounts)
(do-shift xs shift-amount-or-amounts)))
(define+provide/contract (shift/values xs shift-amount-or-amounts [fill-item #f])
((list? (or/c integer? integers?)) (any/c) . ->* . any)
(apply (if (list? shift-amount-or-amounts)
values
(λ xs xs))
(shift xs shift-amount-or-amounts fill-item)))

16
string.rkt
Unescape Escape View File

@ -1,16 +0,0 @@
#lang racket/base
(require "define.rkt" "coerce.rkt")
(define+provide/contract (starts-with? str starter)
(coerce/string? coerce/string? . -> . coerce/boolean?)
(and (<= (string-length starter) (string-length str))
(equal? (substring str 0 (string-length starter)) starter)))
(define+provide/contract (ends-with? str ender)
(coerce/string? coerce/string? . -> . coerce/boolean?)
(and (<= (string-length ender) (string-length str))
(equal? (substring str (- (string-length str) (string-length ender)) (string-length str)) ender)))
(define+provide/contract (capitalized? str)
(coerce/string? . -> . coerce/boolean?)
(char-upper-case? (car (string->list str))))

6
sugar/cache.rkt
Unescape Escape View File

@ -0,0 +1,6 @@
#lang racket/base
(require sugar/define)
(require-via-wormhole "../typed/sugar/cache.rkt")
(provide+safe [make-caching-proc (procedure? . -> . procedure?)]
define/caching)

78
sugar/coerce.rkt
Unescape Escape View File

@ -0,0 +1,78 @@
#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)

15
container.rkt → sugar/container.rkt
Unescape Escape View File

@ -1,6 +1,5 @@
#lang racket/base
(require "define.rkt")
(require "coerce.rkt" "len.rkt" racket/list racket/set racket/sequence racket/stream racket/dict)
(require "define.rkt" "coerce.rkt" "len.rkt" racket/list racket/set racket/sequence racket/stream racket/dict)
(define (sliceable-container? x)
(ormap (λ(proc) (proc x)) (list list? string? symbol? vector? path? (λ(i) (and (not (dict? i)) (sequence? i))))))
@ -9,8 +8,8 @@
(ormap (λ(proc) (proc x)) (list sliceable-container? dict?)))
(define/contract+provide (get container start [end #f])
((gettable-container? any/c) ((or/c (and/c integer? positive?) #f)) . ->* . any/c)
(define+provide+safe (get container start [end #f])
((gettable-container? any/c) ((or/c (and/c integer? positive?) #f)) . ->* . any)
(define result
;; use handler to capture error & print localized error message
@ -35,13 +34,13 @@
(define (listlike-container? container)
(ormap (λ(pred) (pred container)) (list vector? set? sequence?)))
(define/contract+provide (in? item container)
(any/c any/c . -> . coerce/boolean?)
(cond
(define+provide+safe (in? item container)
(any/c any/c . -> . boolean?)
(->boolean (cond
[(list? container) (member item container)]
[(dict? container) (dict-has-key? container item)]
[(path? container) (in? (->path item) (explode-path container))]
[(stringish? container) (regexp-match (->string item) (->string container))]
;; location relevant because dicts and strings are also listlike (= sequences)
[(listlike-container? container) (in? item (->list container))]
[else #f]))
[else #f])))

5
sugar/debug.rkt
Unescape Escape View File

@ -0,0 +1,5 @@
#lang racket/base
(require sugar/define)
(require-via-wormhole "../typed/sugar/debug.rkt")
(provide+safe report report-apply report* repeat time-repeat time-repeat* compare)

98
sugar/define.rkt
Unescape Escape View File

@ -0,0 +1,98 @@
#lang racket/base
(require (for-syntax racket/base))
(require racket/contract)
(provide (all-from-out racket/contract))
;; get gets of typed source file, recompile it without typing in a submodule,
;; then require those identifiers into the current level.
(define-syntax (require-via-wormhole stx)
(syntax-case stx ()
[(_ path-spec)
(let ([mod-name (gensym)])
;; need to use stx as context to get correct require behavior
(datum->syntax stx `(begin
(module mod-name typed/racket/base/no-check
(require sugar/include)
(include-without-lang-line ,(syntax->datum #'path-spec)))
(require (quote mod-name)))))]))
;; each define macro recursively converts any form of define
;; into its lambda form (define name body ...) and then operates on that.
(define-syntax (make-safe-module stx)
(syntax-case stx ()
[(_ name contract)
#'(module+ safe
(require racket/contract)
(provide (contract-out [name contract])))]
[(_ name)
#'(module+ safe
(provide name))]))
(define-syntax (define+provide+safe stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide+safe proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(define name body ...)
(provide name)
(make-safe-module name contract))]))
;; for previously defined identifiers
;; takes args like (provide+safe [ident contract]) or just (provide+safe ident)
;; any number of args.
(define-syntax (provide+safe stx)
(syntax-case stx ()
[(_ items ...)
(datum->syntax stx
`(begin
,@(for/list ([item (in-list (syntax->datum #'(items ...)))])
(define-values (name contract) (if (pair? item)
(values (car item) (cadr item))
(values item #f)))
`(begin
(provide ,name)
(make-safe-module ,name ,@(if contract (list contract) null))))))]))
(define-syntax (define+provide/contract stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide/contract proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide (contract-out [name contract]))
(define name body ...))]))
(define-syntax (define/contract+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...)
#'(define/contract+provide proc contract
(λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...)
#'(begin
(provide name)
(define/contract name contract body ...))]))
(define-syntax (define+provide stx)
(syntax-case stx ()
[(_ (proc arg ... . rest-arg) body ...)
#'(define+provide proc
(λ(arg ... . rest-arg) body ...))]
[(_ name body ...)
#'(begin
(provide name)
(define name body ...))]))
(provide+safe require-via-wormhole
make-safe-module
define+provide+safe
provide+safe
define+provide/contract
define/contract+provide
define+provide)

14
sugar/file.rkt
Unescape Escape View File

@ -0,0 +1,14 @@
#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?)])

7
include.rkt → sugar/include.rkt
Unescape Escape View File

@ -4,9 +4,10 @@
syntax/path-spec
racket/private/increader
compiler/cm-accomplice
racket/match racket/function))
racket/match racket/function)
sugar/define)
(provide include-without-lang-line)
(provide+safe include-without-lang-line)
(define-syntax (do-include stx)
(syntax-case stx ()
@ -140,4 +141,4 @@
(syntax-case stx ()
[(_ fn)
(with-syntax ([_stx stx])
(syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
(syntax/loc stx (do-include _stx _stx _stx fn #f)))]))

4
sugar/info.rkt
Unescape Escape View File

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

5
sugar/len.rkt
Unescape Escape View File

@ -0,0 +1,5 @@
#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?)])

39
sugar/list.rkt
Unescape Escape View File

@ -0,0 +1,39 @@
#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-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? (or/c integer? integers?)) (any/c boolean?) . ->* . list?)]
[shift/values ((list? (or/c integer? integers?)) (any/c) . ->* . 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])
(apply (if (list? shift-amount-or-amounts)
values
(λ xs xs))
(shift xs shift-amount-or-amounts fill-item)))

4
main.rkt → sugar/main.rkt
Unescape Escape View File

@ -8,10 +8,10 @@
"define.rkt"
"file.rkt"
"include.rkt"
"len.rkt"
"list.rkt"
"misc.rkt"
"string.rkt"
"len.rkt"
"xml.rkt")
(provide
@ -23,8 +23,8 @@
"define.rkt"
"file.rkt"
"include.rkt"
"len.rkt"
"list.rkt"
"misc.rkt"
"string.rkt"
"len.rkt"
"xml.rkt"))

5
sugar/misc.rkt
Unescape Escape View File

@ -0,0 +1,5 @@
#lang racket/base
(require sugar/define racket/set sugar/coerce)
(require-via-wormhole "../typed/sugar/misc.rkt")
(provide+safe [bytecount->string (integer? . -> . string?)])

2
scribblings/cache.scrbl → sugar/scribblings/cache.scrbl
Unescape Escape View File

@ -6,7 +6,7 @@
@(my-eval `(require sugar))
@title{Cache}
@defmodule[sugar/cache]
@defmodule[#:multi (sugar/cache (submod sugar/cache safe) typed/sugar/cache)]
If, like Ricky Bobby and me, you want to go fast, then try using more caches. They're wicked fast.

6
scribblings/coerce.scrbl → sugar/scribblings/coerce.scrbl
Unescape Escape View File

@ -6,7 +6,7 @@
@(my-eval `(require sugar))
@title{Coercion}
@defmodule[sugar/coerce]
@defmodule[#:multi (sugar/coerce (submod sugar/coerce safe) typed/sugar/coerce)]
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?]
)]
Predicates that report whether @racket[_v] can be coerced to the specified type.
@bold{Untyped only.} 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 @@ Predicates that report whether @racket[_v] can be coerced to the specified type.
@defproc[(coerce/boolean? [v any/c]) boolean?]
@defproc[(coerce/list? [v any/c]) list?]
)]
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.
@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.
@examples[#:eval my-eval
(define/contract (add-ints x y)

4
scribblings/container.scrbl → sugar/scribblings/container.scrbl
Unescape Escape View File

@ -6,9 +6,9 @@
@(my-eval `(require sugar))
@title{Container}
@defmodule[sugar/container]
@defmodule[#:multi (sugar/container (submod sugar/container safe))]
Type-neutral functions for getting elements out of a container, or testing membership.
Type-neutral functions for getting elements out of a container, or testing membership. @bold{This submodule is untyped only.}
@defproc[

2
scribblings/debug.scrbl → sugar/scribblings/debug.scrbl
Unescape Escape View File

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

2
scribblings/file.scrbl → sugar/scribblings/file.scrbl
Unescape Escape View File

@ -6,7 +6,7 @@
@(my-eval `(require sugar))
@title{File}
@defmodule[sugar/file]
@defmodule[#:multi (sugar/file (submod sugar/file safe) typed/sugar/file)]
File utilities, mostly in the realm of file extensions. These functions don't access the filesystem.

0
scribblings/include.scrbl → sugar/scribblings/include.scrbl
Unescape Escape View File

0
scribblings/installation.scrbl → sugar/scribblings/installation.scrbl
Unescape Escape View File

3
scribblings/len.scrbl → sugar/scribblings/len.scrbl
Unescape Escape View File

@ -6,7 +6,8 @@
@(my-eval `(require sugar))
@title{Len}
@defmodule[sugar/len]
@defmodule[#:multi (sugar/len (submod sugar/len safe) typed/sugar/len)]
@defproc[
(len

0
scribblings/license.scrbl → sugar/scribblings/license.scrbl
Unescape Escape View File

5
scribblings/list.scrbl → sugar/scribblings/list.scrbl
Unescape Escape View File

@ -6,7 +6,8 @@
@(my-eval `(require sugar racket/list))
@title{List}
@defmodule[sugar/list]
@defmodule[#:multi (sugar/list (submod sugar/list safe) typed/sugar/list)]
@defproc[
@ -194,7 +195,7 @@ Move the items in @racket[_lst] to the right (if @racket[_how-far] is positive)
[how-far (or/c integer? (listof integer?))]
[fill-item any/c #f])
any]
Same as @racket[shift], except that when @racket[_how-far] is a list, the resulting lists are returned as multiple values rather than as a list of lists.
@bold{Untyped only.} Same as @racket[shift], except that when @racket[_how-far] is a list, the resulting lists are returned as multiple values rather than as a list of lists.
@examples[#:eval my-eval
(define xs (range 5))

2
scribblings/string.scrbl → sugar/scribblings/string.scrbl
Unescape Escape View File

@ -6,7 +6,7 @@
@(my-eval `(require sugar))
@title{String}
@defmodule[sugar/string]
@defmodule[#:multi (sugar/string (submod sugar/string safe) typed/sugar/string)]
@defproc[

12
scribblings/sugar.scrbl → sugar/scribblings/sugar.scrbl
Unescape Escape View File

@ -6,14 +6,22 @@
@(my-eval `(require sugar))
@title[#:style 'toc]{Sugar: readability & convenience library}
@title[#:style 'toc]{Sugar}
@author[(author+email "Matthew Butterick" "mb@mbtype.com")]
@defmodule[sugar]
@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{This cross-compiling technique relies on @racket[include-without-lang-line] in this library.}
@;local-table-of-contents[]
@include-section["installation.scrbl"]

5
scribblings/xml.scrbl → sugar/scribblings/xml.scrbl
Unescape Escape View File

@ -6,9 +6,10 @@
@(my-eval `(require sugar))
@title{XML}
@defmodule[sugar/xml]
@defmodule[#:multi (sugar/xml (submod sugar/xml safe))]
Making it easier to do the simplest kind of round-trip with XML: convert an XML string to X-expressions, manipulate, and then convert these X-expressions back to an XML string.
Making it easier to do the simplest kind of round-trip with XML: convert an XML string to X-expressions, manipulate, and then convert these X-expressions back to an XML string. @bold{This submodule is untyped only.}
@defproc[
(xml-string->xexprs

7
sugar/string.rkt
Unescape Escape View File

@ -0,0 +1,7 @@
#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?)])

108
test/tests.rkt → sugar/test/main.rkt
Unescape Escape View File

@ -1,7 +1,16 @@
#lang racket/base
(require racket/include rackunit sugar racket/list net/url racket/set racket/match)
(require rackunit net/url racket/set racket/list)
(require "../main.rkt")
;; begin shared typed / untyped tests
(check-equal? (->int 42) 42)
(check-equal? (->int 42.1) 42)
(check-equal? (->int 42+3i) 42)
(check-equal? (->int "42") 42)
(check-equal? (->int '42) 42)
(check-equal? (->int (string->path "42")) 42)
(check-equal? (->int #\A) 65)
(check-equal? (->int (make-list 42 null)) 42)
(check-equal? (->string "foo") "foo")
(check-equal? (->string '()) "")
@ -13,8 +22,6 @@
(check-equal? (->string (string->path file-name-as-text)) file-name-as-text)
(check-equal? (->string #\¶) "")
(check-equal? (->path "foo") (string->path "foo"))
(check-equal? (->path 'foo) (string->path "foo"))
(check-equal? (->path 123) (string->path "123"))
@ -47,41 +54,7 @@
(check-not-equal? (len (make-hash '((a . 1) (b . 2)))) 3) ; len 2
(check-equal? (get '(0 1 2 3 4 5) 2) 2)
(check-exn exn:fail? (λ() (get '(0 1 2 3 4 5) 100))) ; index too big
(check-equal? (get `(0 1 ,(list 2) 3 4 5) 2) (list 2))
(check-equal? (get '(0 1 2 3 4 5) 0 2) '(0 1))
(check-equal? (get (list->vector '(0 1 2 3 4 5)) 2) 2)
(check-equal? (get (list->vector'(0 1 2 3 4 5)) 0 2) (list->vector '(0 1)))
(check-equal? (get "purple" 2) "r")
(check-equal? (get "purple" 0 2) "pu")
(check-equal? (get 'purple 2) 'r)
(check-equal? (get 'purple 0 2) 'pu)
(check-equal? (get (string->path "/root/foo/bar/file.txt") 2) (string->path "foo"))
(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 2) (list (string->path "/") (string->path "root")))
(check-equal? (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'a) (list 1))
(check-exn exn:fail? (λ() (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'z))) ; nonexistent key
(check-equal? (get (string->path "/root/foo/bar/file.txt") 1) (string->path "root"))
(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 3)
(map string->path '("/" "root" "foo")))
(check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'b) 2)
(check-true (2 . in? . '(1 2 3)))
(check-false (4 . in? . '(1 2 3)))
(check-true (2 . in? . (list->vector '(1 2 3))))
(check-false (4 . in? . (list->vector '(1 2 3))))
(check-true ('a . in? . (make-hash '((a . 1) (b . 2) (c . 3)))))
(check-false ('x . in? . (make-hash '((a . 1) (b . 2) (c . 3)))))
(check-true ("o" . in? . "foobar"))
(check-false ("z" . in? . "foobar"))
(check-true ('o . in? . 'foobar))
(check-false ('z . in? . 'foobar))
(check-true ("F" . in? . #\F))
(check-true (in? "foo" (string->path "/root/foo/bar/file.txt")))
(check-false (in? "zam" (string->path "/root/foo/bar/file.txt")))
(check-true ("foobar" . starts-with? . "foo"))
@ -94,15 +67,20 @@
(check-true ("foobar" . ends-with? . "foobar"))
(check-false ("foobar" . ends-with? . "foo"))
; (check-equal? (trim (list "\n" " " 1 2 3 "\n") whitespace?) '(1 2 3))
(check-true (members-unique? '(a b c)))
(check-false (members-unique? '(a b c c)))
(check-true (members-unique? "zoey"))
(check-false (members-unique? "zooey"))
(check-equal? (trimf (list 4 1 2 3 4) even?) '(1 2 3))
(check-equal? (trimf (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8))
;(check-equal? (filter-split '("foo" " " "bar" "\n" "\n" "ino") whitespace?) '(("foo")("bar")("ino")))
(check-equal? (filter-split '("foo" " " "bar" "\n" "\n" "ino") (λ(x) (< (string-length x) 3))) '(("foo")("bar")("ino")))
(check-equal? (filter-split '(1 2 3 4 5 6) even?) '((1)(3)(5)))
(define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
(define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path)
(apply values (map ->path foo-path-strings)))
(match-define (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (map ->path foo-path-strings))
;; test the sample paths before using them for other tests
(define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
(for-each check-equal? (map ->string foo-paths) foo-path-strings)
@ -149,13 +127,11 @@
(check-equal? (slice-at (range 5) 2 #t) '((0 1) (2 3)))
(check-equal? (slice-at (range 5) 3) '((0 1 2) (3 4)))
(check-equal? (slice-at (range 5) 3 #t) '((0 1 2)))
(check-exn exn:fail:contract? (λ() (slice-at (range 5) 0)))
(check-equal? (slicef-at (range 5) even?) '((0 1) (2 3) (4)))
(check-equal? (slicef-at (range 5) odd?) '((0) (1 2) (3 4)))
(check-equal? (slicef-at (range 5) odd? #t) '((1 2) (3 4)))
(check-equal? (slicef-at (range 5) procedure?) '((0 1 2 3 4)))
(check-exn exn:fail:contract? (λ() (slicef-at (range 5) 3)))
(check-equal? (slicef-at '(1 2 2 1 2) even?) '((1) (2) (2 1) (2)))
(check-equal? (slicef-at '(1 2 2 1 2) even? #t) '((2) (2 1) (2)))
@ -176,7 +152,49 @@
(check-equal? (shift xs 5 0) (make-list 5 0))
(check-exn exn:fail? (λ() (shift xs -10)))
(check-equal? (values->list (shift/values xs '(-1 0 1) 'boing)) `((1 2 3 4 boing) ,xs (boing 0 1 2 3)))
;;;;; end common tests
(check-exn exn:fail? (λ _ (slice-at (range 5) 0))) ; needs a positive integer as second arg
(check-exn exn:fail? (λ _ (slicef-at (range 5) 3))) ; needs a procedure as second arg
(check-equal? (get '(0 1 2 3 4 5) 2) 2)
(check-exn exn:fail? (λ() (get '(0 1 2 3 4 5) 100))) ; index too big
(check-equal? (get `(0 1 ,(list 2) 3 4 5) 2) (list 2))
(check-equal? (get '(0 1 2 3 4 5) 0 2) '(0 1))
(check-equal? (get (list->vector '(0 1 2 3 4 5)) 2) 2)
(check-equal? (get (list->vector'(0 1 2 3 4 5)) 0 2) (list->vector '(0 1)))
(check-equal? (get "purple" 2) "r")
(check-equal? (get "purple" 0 2) "pu")
(check-equal? (get 'purple 2) 'r)
(check-equal? (get 'purple 0 2) 'pu)
(check-equal? (get (string->path "/root/foo/bar/file.txt") 2) (string->path "foo"))
(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 2) (list (string->path "/") (string->path "root")))
(check-equal? (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'a) (list 1))
(check-exn exn:fail? (λ() (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'z))) ; nonexistent key
(check-equal? (get (string->path "/root/foo/bar/file.txt") 1) (string->path "root"))
(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 3)
(map string->path '("/" "root" "foo")))
(check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'b) 2)
(check-true (2 . in? . '(1 2 3)))
(check-false (4 . in? . '(1 2 3)))
(check-true (2 . in? . (list->vector '(1 2 3))))
(check-false (4 . in? . (list->vector '(1 2 3))))
(check-true ('a . in? . (make-hash '((a . 1) (b . 2) (c . 3)))))
(check-false ('x . in? . (make-hash '((a . 1) (b . 2) (c . 3)))))
(check-true ("o" . in? . "foobar"))
(check-false ("z" . in? . "foobar"))
(check-true ('o . in? . 'foobar))
(check-false ('z . in? . 'foobar))
(check-true ("F" . in? . #\F))
(check-true (in? "foo" (string->path "/root/foo/bar/file.txt")))
(check-false (in? "zam" (string->path "/root/foo/bar/file.txt")))
(define ys (range 5))
(check-equal? (values->list (shift/values ys '(-1 0 1) 'boing)) `((1 2 3 4 boing) ,xs (boing 0 1 2 3)))
(require xml)

0
test/no-lang-line-source.txt → sugar/test/no-lang-line-source.txt
Unescape Escape View File

0
test/source.rkt → sugar/test/source.rkt
Unescape Escape View File

29
sugar/test/test-require-modes.rkt
Unescape Escape View File

@ -0,0 +1,29 @@
#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))
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at trimf
(define foo (trimf '(1 2 3) odd?))
(check-equal? foo '(2)))
(module rbu racket/base
(require sugar/list rackunit)
(provide (all-defined-out))
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at dropf
(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)))

0
xml.rkt → sugar/xml.rkt
Unescape Escape View File

17
typed/sugar.rkt
Unescape Escape View File

@ -0,0 +1,17 @@
#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")

16
typed/sugar/cache.rkt
Unescape Escape View File

@ -0,0 +1,16 @@
#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 ...))]))

109
typed/sugar/coerce.rkt
Unescape Escape View File

@ -0,0 +1,109 @@
#lang typed/racket/base
(require (for-syntax typed/racket/base racket/syntax))
(require typed/net/url racket/set racket/sequence)
(require typed/sugar/define)
(require "len.rkt") ; want relative path-spec for bilingual conversion
(define-syntax-rule (make-coercion-error-handler target-format x)
(λ(e) (error (format "Can’t convert ~s to ~a" x target-format))))
(define-type Intable (U Lengthable Number String Symbol Char Path))
(define/typed+provide (->int x)
(Intable -> Integer)
(with-handlers ([exn:fail? (make-coercion-error-handler 'integer 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))
(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)]
[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))

2
debug.rkt → typed/sugar/debug.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang racket/base
#lang typed/racket/base
(require (for-syntax racket/base racket/syntax))
(provide (all-defined-out))

39
typed/sugar/define.rkt
Unescape Escape View File

@ -0,0 +1,39 @@
#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)))]))

59
typed/sugar/file.rkt
Unescape Escape View File

@ -0,0 +1,59 @@
#lang typed/racket/base
(require typed/sugar/define typed/sugar/coerce typed/sugar/string racket/path)
(define/typed+provide (get-enclosing-dir p)
(Pathish -> 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 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))
(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)
(map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe)))
(define/typed+provide (has-binary-ext? x)
(Pathish -> Boolean)
(let ([x (->path x)])
(ormap (λ:([ext : String]) (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)
(->path (string-append (->string x) "." (->string ext))))
;; take one extension off path
(define/typed+provide (remove-ext x)
(Pathish -> Path)
;; pass through hidden files (those starting with a dot)
(let ([x (->path x)])
(if (x . starts-with? . ".")
x
(path-replace-suffix x ""))))
;; take all extensions off path
(define/typed+provide (remove-ext* x)
(Pathish -> Path)
;; pass through hidden files (those starting with a dot)
(let ([x (->path x)])
(if (x . starts-with? . ".")
x
(let ([path-with-removed-ext (remove-ext x)])
(if (equal? x path-with-removed-ext)
x
(remove-ext* path-with-removed-ext))))))

11
len.rkt → typed/sugar/len.rkt
Unescape Escape View File

@ -1,9 +1,12 @@
#lang racket/base
#lang typed/racket/base
(require racket/set racket/sequence)
(require "define.rkt")
(require typed/sugar/define)
(define+provide/contract (len x)
((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?)
(provide Lengthable)
(define-type Lengthable (U (Listof Any) String Symbol Path (Vectorof Any) HashTableTop (Setof Any) (Sequenceof Any)))
(define/typed+provide (len x)
(Lengthable -> Nonnegative-Integer)
(cond
[(list? x) (length x)]
[(string? x) (string-length x)]

174
typed/sugar/list.rkt
Unescape Escape View File

@ -0,0 +1,174 @@
#lang typed/racket/base
(require (for-syntax racket/base racket/syntax))
(require (except-in racket/list flatten dropf dropf-right) typed/sugar/define "coerce.rkt" "len.rkt")
(require/typed racket/list [dropf (All (A) (Listof A) (A -> Boolean) -> (Listof A))]
[dropf-right (All (A) (Listof A) (A -> Boolean) -> (Listof A))])
;; 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)))
(dropf-right (dropf xs test-proc) test-proc))
(define/typed+provide slicef-at
;; 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)))))
(case-lambda
[(xs pred)
(slicef-at xs pred #f)]
[(xs pred force?)
(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)])
(if (pred x)
(values (cons x null) (if (not (empty? current-list))
(cons (reverse current-list) list-of-lists)
list-of-lists))
(values (cons x current-list) list-of-lists))))
(let ([list-of-lists (reverse (if (empty? last-list)
list-of-lists
(cons (reverse last-list) list-of-lists)))])
(if (and force? (not (empty? list-of-lists)) (not (pred (caar list-of-lists))))
(cdr list-of-lists)
list-of-lists))]))
(define/typed+provide (slicef-after xs pred)
(All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A))))
(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)])
(if (pred x)
(values empty (cons (reverse (cons x current-list)) list-of-lists))
(values (cons x current-list) list-of-lists))))
(reverse (if (empty? last-list)
list-of-lists
(cons (reverse last-list) list-of-lists))))
(define/typed+provide slice-at
;; 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)))))
(case-lambda
[(xs len)
(slice-at xs len #f)]
[(xs len force?)
(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)])
(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))))
(reverse (if (or (empty? last-list) (and force? (not (= len (length last-list)))))
list-of-lists
(cons (reverse last-list) list-of-lists)))]))
(define/typed+provide (filter-split xs pred)
(All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A))))
(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)])
(if (pred x)
(values empty (if (not (empty? current-list))
(cons (reverse current-list) list-of-lists)
list-of-lists))
(values (cons x current-list) list-of-lists))))
(reverse (if (not (empty? last-list))
(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)))
(for ([item (in-list xs)])
(hash-update! counter item (λ:([v : Integer]) (add1 v)) (λ _ 0)))
counter)
(define/typed+provide (members-unique? x)
(All (A) ((U (Listof A) (Vectorof A) String) -> Boolean))
(cond
[(list? x) (= (len (remove-duplicates x)) (len x))]
[(vector? x) (members-unique? (->list x))]
[(string? x) (members-unique? (string->list x))]
[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 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 '()))))])
(error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1)
"item isn’t"
"items aren’t") " unique:") duplicate-keys))
result))
;; for use inside quasiquote
;; instead of ,(when ...) use ,@(when/splice ...)
;; to avoid voids
(provide when/splice)
(define-syntax (when/splice stx)
(syntax-case stx ()
[(_ test body)
#'(if test (list body) '())]))
(provide 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)))
(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 Index (Listof Index)) -> (Listof (Listof A))))
(let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list
(when (ormap (λ:([bp : Index]) (>= 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
;; because breaking at zero means we've reached the start of the list
(reverse (let loop ([xs xs][bps (reverse (cons 0 bps))])
(if (= (car bps) 0)
(cons xs null) ; return whatever's left, because no more splits are possible
(let-values ([(head tail) (split-at xs (car bps))])
(cons tail (loop head (cdr bps)))))))))
(define/typed+provide shift
(case-> ((Listof Any) (U Integer (Listof Integer)) -> (Listof Any))
((Listof Any) (U Integer (Listof Integer)) Any -> (Listof Any))
((Listof Any) (U Integer (Listof Integer)) Any Boolean -> (Listof Any)))
(case-lambda
[(xs shift-amount-or-amounts)
(shift xs shift-amount-or-amounts #f #f)]
[(xs shift-amount-or-amounts fill-item)
(shift xs shift-amount-or-amounts fill-item #f)]
[(xs shift-amount-or-amounts fill-item cycle)
(define/typed (do-shift xs how-far)
((Listof Any) Integer -> (Listof Any))
(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)
(append (make-list abs-how-far fill-item) (drop-right xs abs-how-far))]
;; otherwise how-far is negative
[else (append (drop xs abs-how-far) (make-list abs-how-far fill-item))]))
(if (list? shift-amount-or-amounts)
(map (λ:([amount : Integer]) (do-shift xs amount)) shift-amount-or-amounts)
(do-shift xs shift-amount-or-amounts))]))

7
misc.rkt → typed/sugar/misc.rkt
Unescape Escape View File

@ -1,9 +1,8 @@
#lang racket/base
(require (for-syntax racket/base))
(require "define.rkt")
(require typed/sugar/define)
(define+provide/contract (bytecount->string bytecount)
(integer? . -> . string?)
(define/typed+provide (bytecount->string bytecount)
(Nonnegative-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))

21
typed/sugar/string.rkt
Unescape Escape View File

@ -0,0 +1,21 @@
#lang typed/racket/base
(require typed/sugar/define typed/sugar/coerce)
(define/typed+provide (starts-with? str starter)
(Stringish Stringish -> 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)
(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)
(let ([str (->string str)])
(char-upper-case? (car (string->list str)))))

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

@ -0,0 +1,22 @@
#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))

163
typed/sugar/test/main.rkt
Unescape Escape View File

@ -0,0 +1,163 @@
#lang typed/racket/base
(require racket/include typed/rackunit typed/net/url racket/set racket/list racket/match)
(require typed/sugar)
;; begin shared typed / untyped tests
(check-equal? (->int 42) 42)
(check-equal? (->int 42.1) 42)
(check-equal? (->int 42+3i) 42)
(check-equal? (->int "42") 42)
(check-equal? (->int '42) 42)
(check-equal? (->int (string->path "42")) 42)
(check-equal? (->int #\A) 65)
(check-equal? (->int (make-list 42 null)) 42)
(check-equal? (->string "foo") "foo")
(check-equal? (->string '()) "")
(check-equal? (->string (void)) "")
(check-equal? (->string 'foo) "foo")
(check-equal? (->string 123) "123")
;(check-equal? (->string (string->url "foo/bar.html")) "foo/bar.html")
(define file-name-as-text "foo.txt")
(check-equal? (->string (string->path file-name-as-text)) file-name-as-text)
(check-equal? (->string #\¶) "")
(check-equal? (->path "foo") (string->path "foo"))
(check-equal? (->path 'foo) (string->path "foo"))
(check-equal? (->path 123) (string->path "123"))
(check-equal? (->path (string->url "foo/bar.html")) (string->path "foo/bar.html"))
(check-equal? (->list '(1 2 3)) '(1 2 3))
(check-equal? (->list (list->vector '(1 2 3))) '(1 2 3))
(check-equal? (->list (set 1 2 3)) '(3 2 1))
(check-equal? (->list "foo") (list "foo"))
(check-true (->boolean #t))
(check-false (->boolean #f))
(check-true (->boolean "#f"))
(check-true (->boolean "foo"))
(check-true (->boolean '()))
(check-true (->boolean '(1 2 3)))
(check-equal? (len '(1 2 3)) 3)
(check-not-equal? (len '(1 2)) 3) ; len 2
(check-equal? (len "foo") 3)
(check-not-equal? (len "fo") 3) ; len 2
(check-equal? (len 'foo) 3)
(check-not-equal? (len 'fo) 3) ; len 2
(check-equal? (len (list->vector '(1 2 3))) 3)
(check-not-equal? (len (list->vector '(1 2))) 3) ; len 2
(check-equal? (len (set 1 2 3)) 3)
(check-not-equal? (len (set 1 2)) 3) ; len 2
(check-equal? (len (make-hash '((a . 1) (b . 2) (c . 3)))) 3)
(check-not-equal? (len (make-hash '((a . 1) (b . 2)))) 3) ; len 2
(check-true ("foobar" . starts-with? . "foo"))
(check-true ("foobar" . starts-with? . "f"))
(check-true ("foobar" . starts-with? . "foobar"))
(check-false ("foobar" . starts-with? . "bar"))
(check-false ("foobar" . starts-with? . "."))
(check-true ("foobar" . ends-with? . "bar"))
(check-true ("foobar" . ends-with? . "r"))
(check-true ("foobar" . ends-with? . "foobar"))
(check-false ("foobar" . ends-with? . "foo"))
(check-true (members-unique? '(a b c)))
(check-false (members-unique? '(a b c c)))
(check-true (members-unique? "zoey"))
(check-false (members-unique? "zooey"))
(check-equal? (trimf (list 4 1 2 3 4) even?) '(1 2 3))
(check-equal? (trimf (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8))
(check-equal? (filter-split '("foo" " " "bar" "\n" "\n" "ino") (λ:([x : String]) (< (string-length x) 3))) '(("foo")("bar")("ino")))
(check-equal? (filter-split '(1 2 3 4 5 6) even?) '((1)(3)(5)))
(define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
(match-define (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (map ->path foo-path-strings))
;; test the sample paths before using them for other tests
(define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
(for-each check-equal? (map ->string foo-paths) foo-path-strings)
(check-false (has-ext? foo-path 'txt))
(check-true (foo.txt-path . has-ext? . 'txt))
(check-true ((->path "foo.TXT") . has-ext? . 'txt))
(check-true (has-ext? foo.bar.txt-path 'txt))
(check-false (foo.bar.txt-path . has-ext? . 'doc)) ; wrong extension
(check-equal? (get-ext (->path "foo.txt")) "txt")
(check-false (get-ext "foo"))
(check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt"))
(check-equal? (remove-ext foo-path) foo-path)
(check-equal? (remove-ext (->path ".foo.txt")) (->path ".foo.txt"))
(check-equal? (remove-ext foo.txt-path) foo-path)
(check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)
(check-not-equal? (remove-ext foo.bar.txt-path) foo-path) ; does not remove all extensions
(check-equal? (remove-ext* foo-path) foo-path)
(check-equal? (remove-ext* foo.txt-path) foo-path)
(check-equal? (remove-ext* (->path ".foo.txt")) (->path ".foo.txt"))
(check-not-equal? (remove-ext* foo.bar.txt-path) foo.bar-path) ; removes more than one ext
(check-equal? (remove-ext* foo.bar.txt-path) foo-path)
(check-true (starts-with? "foobar" "foo"))
(check-true (starts-with? "foobar" "foobar"))
(check-false (starts-with? "foobar" "zam"))
(check-false (starts-with? "foobar" "foobars"))
(check-true (ends-with? "foobar" "bar"))
(check-false (ends-with? "foobar" "zam"))
(check-true (ends-with? "foobar" "foobar"))
(check-false (ends-with? "foobar" "foobars"))
(check-true (capitalized? "Brennan"))
(check-false (capitalized? "foobar"))
(check-equal? (slice-at (range 5) 1) '((0) (1) (2) (3) (4)))
(check-equal? (slice-at (range 5) 2) '((0 1) (2 3) (4)))
(check-equal? (slice-at (range 5) 2 #t) '((0 1) (2 3)))
(check-equal? (slice-at (range 5) 3) '((0 1 2) (3 4)))
(check-equal? (slice-at (range 5) 3 #t) '((0 1 2)))
(check-equal? (slicef-at (range 5) even?) '((0 1) (2 3) (4)))
(check-equal? (slicef-at (range 5) odd?) '((0) (1 2) (3 4)))
(check-equal? (slicef-at (range 5) odd? #t) '((1 2) (3 4)))
(check-equal? (slicef-at (range 5) procedure?) '((0 1 2 3 4)))
(check-equal? (slicef-at '(1 2 2 1 2) even?) '((1) (2) (2 1) (2)))
(check-equal? (slicef-at '(1 2 2 1 2) even? #t) '((2) (2 1) (2)))
(check-equal? (sublist (range 5) 0 0) '())
(check-equal? (sublist (range 5) 0 1) '(0))
(check-equal? (sublist (range 5) 0 5) '(0 1 2 3 4))
(check-equal? (break-at '(5 6 7 8) '()) '((5 6 7 8)))
(check-equal? (break-at '(5 6 7 8) '(0)) '((5 6 7 8)))
(check-equal? (break-at '(5 6 7 8) '(1 2 3)) '((5) (6) (7) (8)))
(check-equal? (break-at '(5 6 7 8) '(1 3)) '((5) (6 7) (8)))
(check-equal? (break-at '(5 6 7 8) '(1)) (break-at '(5 6 7 8) 1))
(define xs (range 5))
(check-equal? (map (λ(a b c) (list a b c)) (shift xs -1) (shift xs 0) (shift xs 1)) '((1 0 #f) (2 1 0) (3 2 1) (4 3 2) (#f 4 3)))
(check-equal? (shift xs '(-1 0 1) 'boing) `((1 2 3 4 boing) ,xs (boing 0 1 2 3)))
(check-equal? (shift xs 5 0) (make-list 5 0))
(check-exn exn:fail? (λ() (shift xs -10)))
;; end shared tests
#|
;; todo: revise `check-typing-fails` to make it compatible with 6.0
(check-typing-fails (slice-at (range 5) 0)) ; needs a positive integer as second arg
(check-typing-fails (slicef-at (range 5) 3)) ; needs a procedure as second arg
|#

1
typed/sugar/test/no-lang-line-source.txt
Unescape Escape View File

@ -0,0 +1 @@
(define no-lang-symbol 'bar)

3
typed/sugar/test/source.rkt
Unescape Escape View File

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

29
typed/sugar/test/test-require-modes.rkt
Unescape Escape View File

@ -0,0 +1,29 @@
#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))
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at trimf
(define foo (trimf '(1 2 3) odd?))
(check-equal? foo '(2)))
(module rbu racket/base
(require sugar/list rackunit)
(provide (all-defined-out))
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at dropf
(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)))

45
typed/sugar/xml.rkt
Unescape Escape View File

@ -0,0 +1,45 @@
#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)))))
|#
Write Preview
Loading…
Cancel
Save