untype
parent
37f923be8d
commit
809b7435b7
@ -0,0 +1,16 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base) "define.rkt")
|
||||
|
||||
(define+provide+safe (make-caching-proc base-proc)
|
||||
(procedure? . -> . procedure?)
|
||||
(let ([cache (make-hash)])
|
||||
(λ args
|
||||
(hash-ref! cache args (λ () (apply base-proc args))))))
|
||||
|
||||
(provide+safe define/caching)
|
||||
(define-syntax (define/caching stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name arg ... . rest-arg) body ...)
|
||||
#'(define/caching name (λ(arg ... . rest-arg) body ...))]
|
||||
[(_ name body ...)
|
||||
#'(define name (make-caching-proc body ...))]))
|
@ -0,0 +1,165 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax))
|
||||
(require net/url racket/set racket/sequence "len.rkt" "define.rkt")
|
||||
|
||||
(define-syntax-rule (make-coercion-error-handler target-format x)
|
||||
(λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format))))
|
||||
|
||||
|
||||
(define+provide+safe (->int x)
|
||||
(any/c . -> . integer?)
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'int x)])
|
||||
(cond
|
||||
[(or (integer? x) (real? x)) (inexact->exact (floor x))]
|
||||
[(complex? x) (->int (real-part x))]
|
||||
[(string? x) (let ([strnum (string->number x)])
|
||||
(if (real? strnum) (->int strnum) (error 'ineligible-string)))]
|
||||
[(or (symbol? x) (path? x)) (->int (->string x))]
|
||||
[(char? x) (char->integer x)]
|
||||
[else (len x)]))) ; covers Lengthable types
|
||||
|
||||
|
||||
(define+provide+safe (->string x)
|
||||
(any/c . -> . string?)
|
||||
(if (string? x)
|
||||
x ; fast exit for strings
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'string x)])
|
||||
(cond
|
||||
[(or (equal? '() x) (void? x)) ""]
|
||||
[(symbol? x) (symbol->string x)]
|
||||
[(number? x) (number->string x)]
|
||||
[(path? x) (path->string x)]
|
||||
[(char? x) (format "~a" x)]
|
||||
[(url? x) (url->string x)]
|
||||
[else (error 'bad-type)]))))
|
||||
|
||||
|
||||
;; ->symbol, ->path, and ->url are just variants on ->string
|
||||
;; two advantages: return correct type, and more accurate error
|
||||
|
||||
;; no need for "Symbolable" type - same as Stringable
|
||||
(define+provide+safe (->symbol x)
|
||||
(any/c . -> . symbol?)
|
||||
(if (symbol? x)
|
||||
x
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)])
|
||||
(string->symbol (->string x)))))
|
||||
|
||||
|
||||
(define+provide+safe (->path x)
|
||||
(any/c . -> . path?)
|
||||
(if (path? x)
|
||||
x
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'path x)])
|
||||
(cond
|
||||
[(url? x) (apply build-path (map path/param-path (url-path x)))]
|
||||
[else (string->path (->string x))]))))
|
||||
|
||||
|
||||
(define+provide+safe (->url x)
|
||||
(any/c . -> . url?)
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'url x)])
|
||||
(string->url (->string x))))
|
||||
|
||||
|
||||
(define+provide+safe (->complete-path x)
|
||||
(any/c . -> . complete-path?)
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)])
|
||||
(path->complete-path (->path x))))
|
||||
|
||||
|
||||
(define+provide+safe (->list x)
|
||||
(any/c . -> . list?)
|
||||
(if (list? x)
|
||||
x
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'list x)])
|
||||
(cond
|
||||
[(string? x) (list x)]
|
||||
[(vector? x) (for/list ([i (in-vector x)])
|
||||
i)]
|
||||
[(set? x) (set->list x)]
|
||||
;; conditional sequencing relevant because hash also tests true for `sequence?`
|
||||
[(hash? x) (hash->list x)]
|
||||
[(integer? x) (list x)] ; because an integer tests #t for sequence?
|
||||
[(sequence? x) (sequence->list x)]
|
||||
;[(stream? x) (stream->list x)] ;; no support for streams in TR
|
||||
[else (list x)]))))
|
||||
|
||||
|
||||
(define+provide+safe (->vector x)
|
||||
(any/c . -> . vector?)
|
||||
(if (vector? x)
|
||||
x
|
||||
(with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)])
|
||||
(list->vector (->list x)))))
|
||||
|
||||
|
||||
(define+provide+safe (->boolean x)
|
||||
(any/c . -> . boolean?)
|
||||
(and x #t))
|
||||
|
||||
|
||||
;; coercion contracts & *ish predicates
|
||||
;; only make sense in untyped code
|
||||
;; thus they are here.
|
||||
(define-syntax-rule (make-blame-handler try-proc expected-sym)
|
||||
(λ(b)
|
||||
(λ(x)
|
||||
(with-handlers ([exn:fail? (λ(e)
|
||||
(raise-blame-error
|
||||
b x
|
||||
'(expected: "~a" given: "~e")
|
||||
expected-sym x))])
|
||||
(try-proc x)))))
|
||||
|
||||
|
||||
(provide+safe make-coercion-contract)
|
||||
(define-syntax (make-coercion-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stem coerce-proc)
|
||||
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]
|
||||
[can-be-stem? (format-id stx "can-be-~a?" #'stem)])
|
||||
#'(make-contract
|
||||
#:name 'coerce/stem?
|
||||
#:projection (make-blame-handler coerce-proc 'can-be-stem?)))]
|
||||
[(_ stem)
|
||||
(with-syntax ([->stem (format-id stx "->~a" #'stem)])
|
||||
#'(make-coercion-contract stem ->stem))]))
|
||||
|
||||
|
||||
(define-syntax (define+provide-coercion-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stem)
|
||||
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)])
|
||||
#'(begin
|
||||
(provide+safe coerce/stem?)
|
||||
(define coerce/stem? (make-coercion-contract stem))))]))
|
||||
|
||||
|
||||
(define+provide-coercion-contract int)
|
||||
(define+provide-coercion-contract string)
|
||||
(define+provide-coercion-contract symbol)
|
||||
(define+provide-coercion-contract path)
|
||||
(define+provide-coercion-contract boolean)
|
||||
(define+provide-coercion-contract list)
|
||||
|
||||
|
||||
(define-syntax (make-*ish-predicate stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stem)
|
||||
(with-syntax ([stemish? (format-id stx "~aish?" #'stem)]
|
||||
[->stem (format-id stx "->~a" #'stem)])
|
||||
#`(begin
|
||||
(provide+safe stemish?)
|
||||
(define (stemish? x)
|
||||
(with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))]))
|
||||
|
||||
|
||||
(make-*ish-predicate int)
|
||||
(make-*ish-predicate string)
|
||||
(make-*ish-predicate symbol)
|
||||
(make-*ish-predicate url)
|
||||
(make-*ish-predicate complete-path)
|
||||
(make-*ish-predicate path)
|
||||
(make-*ish-predicate list)
|
||||
(make-*ish-predicate vector)
|
@ -1,13 +1,94 @@
|
||||
#lang racket/base
|
||||
(require sugar/define)
|
||||
(require-via-wormhole "../typed/sugar/debug.rkt")
|
||||
(require (for-syntax racket/base racket/syntax) "define.rkt")
|
||||
|
||||
(provide+safe report report/line report/file
|
||||
report* report*/line report*/file
|
||||
report-apply repeat time-repeat time-repeat* compare)
|
||||
|
||||
(define-syntax (report stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr) #'(report expr expr)]
|
||||
[(_ expr name)
|
||||
#'(let ([expr-result expr])
|
||||
(eprintf "~a = ~v\n" 'name expr-result)
|
||||
expr-result)]))
|
||||
|
||||
|
||||
(define-syntax (report/line stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr) #'(report/line expr expr)]
|
||||
[(_ expr name)
|
||||
(with-syntax ([line (syntax-line #'expr)])
|
||||
#'(let ([expr-result expr])
|
||||
(eprintf "~a = ~v on line ~v\n" 'name expr-result line)
|
||||
expr-result))]))
|
||||
|
||||
|
||||
(define-syntax (report/file stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr) #'(report/file expr expr)]
|
||||
[(_ expr name)
|
||||
(with-syntax ([file (syntax-source #'expr)]
|
||||
[line (syntax-line #'expr)])
|
||||
#'(let ([expr-result expr])
|
||||
(eprintf "~a = ~v on line ~v in \"~a\"\n" 'name expr-result line 'file)
|
||||
expr-result))]))
|
||||
|
||||
|
||||
(define-syntax-rule (define-multi-version multi-name name)
|
||||
(define-syntax-rule (multi-name x (... ...))
|
||||
(begin (name x) (... ...))))
|
||||
|
||||
(define-multi-version report* report)
|
||||
(define-multi-version report*/line report/line)
|
||||
(define-multi-version report*/file report/file)
|
||||
|
||||
|
||||
(define-syntax report-apply
|
||||
(syntax-rules ()
|
||||
[(report-apply proc expr)
|
||||
(let ([lst expr])
|
||||
(report (apply proc lst) (apply proc expr))
|
||||
lst)]
|
||||
[(report-apply proc expr #:line)
|
||||
(let ([lst expr])
|
||||
(report (apply proc lst) (apply proc expr) #:line)
|
||||
lst)]))
|
||||
|
||||
#|
|
||||
(define-syntax (verbalize stx)
|
||||
(syntax-case stx ()
|
||||
[(_ proc args ...)
|
||||
(with-syntax ([proc-input (format-id stx "args to ~a" #'proc)])
|
||||
#'(begin
|
||||
(let () (report (list args ...) proc-input) (void))
|
||||
(report (proc args ...))))]))
|
||||
|#
|
||||
|
||||
|
||||
|
||||
|
||||
(define-syntax-rule (repeat num expr ...)
|
||||
(for/last ([i (in-range num)])
|
||||
expr ...))
|
||||
|
||||
|
||||
(define-syntax-rule (time-repeat num expr ...)
|
||||
(time (repeat num expr ...)))
|
||||
|
||||
|
||||
(define-syntax (time-repeat* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ num expr ...)
|
||||
#'(let ([n num])
|
||||
(values (time-repeat n expr) ...))]))
|
||||
|
||||
|
||||
(define-syntax (compare stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr id id-alt ...)
|
||||
#'(values expr (let ([id id-alt]) expr) ...)]))
|
||||
|
||||
(module reader racket/base
|
||||
(require syntax/module-reader racket/syntax version/utils)
|
||||
(provide (rename-out [debug-read read]
|
@ -1,11 +1,10 @@
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base
|
||||
syntax/path-spec
|
||||
racket/private/increader
|
||||
compiler/cm-accomplice
|
||||
racket/match racket/function)
|
||||
sugar/define)
|
||||
"define.rkt")
|
||||
|
||||
(provide+safe include-without-lang-line)
|
||||
|
@ -1,7 +1,6 @@
|
||||
#lang info
|
||||
(define collection 'multi)
|
||||
(define deps '("base"
|
||||
"typed-racket-lib"
|
||||
"typed-racket-more"
|
||||
"rackunit-lib"))
|
||||
(define build-deps '("scribble-lib" "racket-doc" "typed-racket-doc"))
|
||||
(define collection "sugar")
|
||||
(define deps '("base" "rackunit-lib"))
|
||||
(define build-deps '("scribble-lib" "racket-doc"))
|
||||
(define scribblings '(("scribblings/sugar.scrbl" ())))
|
||||
(define compile-omit-paths '("test"))
|
@ -0,0 +1,15 @@
|
||||
#lang racket/base
|
||||
(require "define.rkt" racket/set racket/sequence)
|
||||
|
||||
(define+provide+safe (len x)
|
||||
((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?)
|
||||
(cond
|
||||
[(list? x) (length x)]
|
||||
[(string? x) (string-length x)]
|
||||
[(symbol? x) (len (symbol->string x))]
|
||||
[(path? x) (len (path->string x))]
|
||||
[(vector? x) (vector-length x)]
|
||||
[(hash? x) (len (hash-keys x))]
|
||||
[(set? x) (len (set->list x))]
|
||||
[(and (sequence? x) (not (integer? x))) (len (sequence->list x))]
|
||||
[else (error "len: can't calculate length of" x)]))
|
@ -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).
|
@ -0,0 +1,46 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval (for-label racket sugar))
|
||||
|
||||
@(define my-eval (make-base-eval))
|
||||
@(my-eval `(require sugar))
|
||||
|
||||
|
||||
@title[#:style 'toc]{Sugar}
|
||||
|
||||
@author[(author+email "Matthew Butterick" "mb@mbtype.com")]
|
||||
|
||||
@defmodule[#:multi (sugar (submod sugar safe))]
|
||||
|
||||
A collection of small functions to help make Racket code simpler & more readable.
|
||||
|
||||
Sugar can be invoked two ways: as an ordinary library, or as a library with contracts (using the @tt{safe} submodule).
|
||||
|
||||
|
||||
@;local-table-of-contents[]
|
||||
|
||||
@include-section["installation.scrbl"]
|
||||
|
||||
@include-section["cache.scrbl"]
|
||||
|
||||
@include-section["coerce.scrbl"]
|
||||
|
||||
@include-section["container.scrbl"]
|
||||
|
||||
@include-section["debug.scrbl"]
|
||||
|
||||
@include-section["file.scrbl"]
|
||||
|
||||
@include-section["include.scrbl"]
|
||||
|
||||
@include-section["len.scrbl"]
|
||||
|
||||
@include-section["list.scrbl"]
|
||||
|
||||
@include-section["string.scrbl"]
|
||||
|
||||
@include-section["xml.scrbl"]
|
||||
|
||||
@include-section["license.scrbl"]
|
||||
|
||||
@;index-section[]
|
@ -1,21 +1,25 @@
|
||||
#lang typed/racket/base
|
||||
(require typed/sugar/define "coerce.rkt")
|
||||
#lang racket/base
|
||||
(require "define.rkt" "coerce.rkt")
|
||||
|
||||
|
||||
(define/typed+provide (starts-with? str starter)
|
||||
(Stringish Stringish -> Boolean)
|
||||
(define+provide+safe (starts-with? str starter)
|
||||
(string? string? . -> . coerce/boolean?)
|
||||
(let ([str (->string str)]
|
||||
[starter (->string starter)])
|
||||
(and (<= (string-length starter) (string-length str))
|
||||
(equal? (substring str 0 (string-length starter)) starter))))
|
||||
|
||||
(define/typed+provide (ends-with? str ender)
|
||||
(Stringish Stringish -> Boolean)
|
||||
|
||||
(define+provide+safe (ends-with? str ender)
|
||||
(string? string? . -> . coerce/boolean?)
|
||||
(let ([str (->string str)]
|
||||
[ender (->string ender)])
|
||||
(and (<= (string-length ender) (string-length str))
|
||||
(equal? (substring str (- (string-length str) (string-length ender)) (string-length str)) ender))))
|
||||
|
||||
(define/typed+provide (capitalized? str)
|
||||
(Stringish -> Boolean)
|
||||
|
||||
(define+provide+safe (capitalized? str)
|
||||
(string? . -> . coerce/boolean?)
|
||||
(let ([str (->string str)])
|
||||
(char-upper-case? (car (string->list str)))))
|
||||
|
@ -1,6 +0,0 @@
|
||||
#lang racket/base
|
||||
(require sugar/define)
|
||||
(require-via-wormhole "../typed/sugar/cache.rkt")
|
||||
|
||||
(provide+safe [make-caching-proc (procedure? . -> . procedure?)]
|
||||
define/caching)
|
@ -1,3 +0,0 @@
|
||||
#lang racket/base
|
||||
;; isolate typed requires in a helper file so the untyped versions can be substituted on the untyped side
|
||||
(require net/url)
|
@ -1,75 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax) sugar/define net/url)
|
||||
(require-via-wormhole "../typed/sugar/coerce.rkt")
|
||||
|
||||
(provide+safe [->int (any/c . -> . integer?)]
|
||||
[->string (any/c . -> . string?)]
|
||||
[->symbol (any/c . -> . symbol?)]
|
||||
[->path (any/c . -> . path?)]
|
||||
[->complete-path (any/c . -> . complete-path?)]
|
||||
[->url (any/c . -> . url?)]
|
||||
[->list (any/c . -> . list?)]
|
||||
[->vector (any/c . -> . vector?)]
|
||||
[->boolean (any/c . -> . boolean?)])
|
||||
|
||||
;; coercion contracts & *ish predicates
|
||||
;; only make sense in untyped code
|
||||
;; thus they are here.
|
||||
(define-syntax-rule (make-blame-handler try-proc expected-sym)
|
||||
(λ(b)
|
||||
(λ(x)
|
||||
(with-handlers ([exn:fail? (λ(e)
|
||||
(raise-blame-error
|
||||
b x
|
||||
'(expected: "~a" given: "~e")
|
||||
expected-sym x))])
|
||||
(try-proc x)))))
|
||||
|
||||
(provide+safe make-coercion-contract)
|
||||
(define-syntax (make-coercion-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stem coerce-proc)
|
||||
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]
|
||||
[can-be-stem? (format-id stx "can-be-~a?" #'stem)])
|
||||
#'(make-contract
|
||||
#:name 'coerce/stem?
|
||||
#:projection (make-blame-handler coerce-proc 'can-be-stem?)))]
|
||||
[(_ stem)
|
||||
(with-syntax ([->stem (format-id stx "->~a" #'stem)])
|
||||
#'(make-coercion-contract stem ->stem))]))
|
||||
|
||||
(define-syntax (define+provide-coercion-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stem)
|
||||
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)])
|
||||
#'(begin
|
||||
(provide+safe coerce/stem?)
|
||||
(define coerce/stem? (make-coercion-contract stem))))]))
|
||||
|
||||
(define+provide-coercion-contract int)
|
||||
(define+provide-coercion-contract string)
|
||||
(define+provide-coercion-contract symbol)
|
||||
(define+provide-coercion-contract path)
|
||||
(define+provide-coercion-contract boolean)
|
||||
(define+provide-coercion-contract list)
|
||||
|
||||
|
||||
|
||||
(define-syntax (make-*ish-predicate stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stem)
|
||||
(with-syntax ([stemish? (format-id stx "~aish?" #'stem)]
|
||||
[->stem (format-id stx "->~a" #'stem)])
|
||||
#`(begin
|
||||
(provide+safe stemish?)
|
||||
(define (stemish? x)
|
||||
(with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))]))
|
||||
|
||||
(make-*ish-predicate int)
|
||||
(make-*ish-predicate string)
|
||||
(make-*ish-predicate symbol)
|
||||
(make-*ish-predicate url)
|
||||
(make-*ish-predicate complete-path)
|
||||
(make-*ish-predicate path)
|
||||
(make-*ish-predicate list)
|
||||
(make-*ish-predicate vector)
|
@ -1,14 +0,0 @@
|
||||
#lang racket/base
|
||||
(require sugar/define racket/set sugar/coerce)
|
||||
(require-via-wormhole "../typed/sugar/file.rkt")
|
||||
|
||||
(provide+safe
|
||||
[get-enclosing-dir (coerce/path? . -> . path?)]
|
||||
[has-ext? (coerce/path? coerce/string? . -> . coerce/boolean?)]
|
||||
[get-ext (coerce/path? . -> . (or/c #f string?))]
|
||||
binary-extensions
|
||||
[has-binary-ext? (coerce/path? . -> . coerce/boolean?)]
|
||||
[add-ext (coerce/string? coerce/string? . -> . coerce/path?)]
|
||||
[remove-ext (coerce/path? . -> . path?)]
|
||||
[remove-ext* (coerce/path? . -> . path?)])
|
||||
|
@ -1,4 +0,0 @@
|
||||
#lang info
|
||||
(define scribblings '(("scribblings/sugar.scrbl" ())))
|
||||
|
||||
(define compile-omit-paths '("test"))
|
@ -1,5 +0,0 @@
|
||||
#lang racket/base
|
||||
(require sugar/define racket/set)
|
||||
(require-via-wormhole "../typed/sugar/len.rkt")
|
||||
|
||||
(provide+safe [len ((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?)])
|
@ -1,3 +0,0 @@
|
||||
#lang racket/base
|
||||
;; isolate typed requires in a helper file so the untyped versions can be substituted on the untyped side
|
||||
(require (only-in racket/list dropf dropf-right))
|
@ -1,40 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/list racket/set racket/function sugar/define)
|
||||
(require "len.rkt" "coerce.rkt")
|
||||
|
||||
(require-via-wormhole "../typed/sugar/list.rkt")
|
||||
|
||||
(define (list-of-lists? xs) (and (list? xs) (andmap list? xs)))
|
||||
(define (index? x) (and (integer? x) (not (negative? x))))
|
||||
|
||||
(define increasing-nonnegative? (λ(xs) (apply < -1 xs)))
|
||||
(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?))
|
||||
|
||||
(define (integers? x) (and (list? x) (andmap integer? x)))
|
||||
|
||||
(provide+safe [trimf (list? procedure? . -> . list?)]
|
||||
[slicef (list? procedure? . -> . list-of-lists?)]
|
||||
[slicef-at ((list? procedure?) (boolean?) . ->* . list-of-lists?)]
|
||||
[slicef-after (list? procedure? . -> . list-of-lists?)]
|
||||
[slice-at ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)]
|
||||
[filter-split (list? predicate/c . -> . list-of-lists?)]
|
||||
[frequency-hash (list? . -> . hash?)]
|
||||
[members-unique? ((or/c list? vector? string?) . -> . boolean?)]
|
||||
[members-unique?/error ((or/c list? vector? string?) . -> . boolean?)]
|
||||
when/splice
|
||||
values->list
|
||||
[sublist (list? index? index? . -> . list?)]
|
||||
[break-at (list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?)]
|
||||
[shift ((list? integer?) (any/c boolean?) . ->* . list?)]
|
||||
[shifts ((list? integers?) (any/c boolean?) . ->* . (listof list?))]
|
||||
[shift/values ((list? (or/c integers? integer?)) (any/c boolean?) . ->* . any)])
|
||||
|
||||
|
||||
;; todo: can this work in typed context? couldn't figure out how to polymorphically `apply values`
|
||||
;; macro doesn't work either
|
||||
(define (shift/values xs shift-amount-or-amounts [fill-item #f] [cycle #f])
|
||||
(apply values ((if (list? shift-amount-or-amounts)
|
||||
shifts
|
||||
shift) xs shift-amount-or-amounts fill-item cycle)))
|
||||
|
@ -1,5 +0,0 @@
|
||||
#lang racket/base
|
||||
(require sugar/define racket/set sugar/coerce)
|
||||
(require-via-wormhole "../typed/sugar/misc.rkt")
|
||||
|
||||
(provide+safe [bytecount->string (integer? . -> . string?)])
|
@ -1,11 +0,0 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval (for-label racket sugar))
|
||||
|
||||
@title{Include}
|
||||
@defmodule[sugar/include]
|
||||
|
||||
@defform[(include-without-lang-line path-spec)]
|
||||
Inline the syntax in the file designated by @racket[_path-spec], after stripping off the @tt{#lang} line of the file (if it exists, otherwise just @racket[include] the file as usual).
|
||||
|
||||
Why? So you can take the code from a working source file and recompile it under a different @tt{#lang}. Why? Well, you could take code from a @tt{#lang typed/racket} source file and recompile as @tt{#lang typed/racket/no-check}. Why? Because then you could make typed and untyped modules from the same code without the mandatory contracts imposed by @racket[require/typed].
|
@ -1,51 +0,0 @@
|
||||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval (for-label racket sugar (only-in typed/racket require/typed)))
|
||||
|
||||
@(define my-eval (make-base-eval))
|
||||
@(my-eval `(require sugar))
|
||||
|
||||
|
||||
@title[#:style 'toc]{Sugar}
|
||||
|
||||
@author[(author+email "Matthew Butterick" "mb@mbtype.com")]
|
||||
|
||||
@defmodule[#:multi (sugar (submod sugar safe) typed/sugar)]
|
||||
|
||||
A collection of small functions to help make Racket code simpler & more readable.
|
||||
|
||||
Sugar can be invoked three ways: as an untyped library, as an untyped library with contracts (using the @tt{safe} submodule), or as a typed library.
|
||||
|
||||
A few functions are only available as untyped or typed. These exceptions are noted below.
|
||||
|
||||
The typed version of Sugar is implemented ``natively'' in the sense that it is compiled separately with type annotations. It is not a @racket[require/typed] wrapper around the untyped code. This avoids the contract barrier that is otherwise automatically imposed between typed and untyped code.
|
||||
|
||||
@margin-note{I explain more about this cross-compiling technique in @link["http://unitscale.com/mb/technique/dual-typed-untyped-library.html"]{Making a dual typed / untyped Racket library}.}
|
||||
|
||||
@;local-table-of-contents[]
|
||||
|
||||
@include-section["installation.scrbl"]
|
||||
|
||||
@include-section["cache.scrbl"]
|
||||
|
||||
@include-section["coerce.scrbl"]
|
||||
|
||||
@include-section["container.scrbl"]
|
||||
|
||||
@include-section["debug.scrbl"]
|
||||
|
||||
@include-section["file.scrbl"]
|
||||
|
||||
@include-section["include.scrbl"]
|
||||
|
||||
@include-section["len.scrbl"]
|
||||
|
||||
@include-section["list.scrbl"]
|
||||
|
||||
@include-section["string.scrbl"]
|
||||
|
||||
@include-section["xml.scrbl"]
|
||||
|
||||
@include-section["license.scrbl"]
|
||||
|
||||
@;index-section[]
|
@ -1,7 +0,0 @@
|
||||
#lang racket/base
|
||||
(require sugar/define racket/set sugar/coerce)
|
||||
(require-via-wormhole "../typed/sugar/string.rkt")
|
||||
|
||||
(provide+safe [starts-with? (coerce/string? coerce/string? . -> . coerce/boolean?)]
|
||||
[ends-with? (coerce/string? coerce/string? . -> . coerce/boolean?)]
|
||||
[capitalized? (coerce/string? . -> . coerce/boolean?)])
|
@ -1,3 +0,0 @@
|
||||
#lang typed/racket
|
||||
|
||||
(define included-symbol 'bar)
|
@ -1,6 +1,6 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax))
|
||||
(require sugar/define)
|
||||
(require "define.rkt")
|
||||
(provide+safe module-test-external module-test-internal module-test-internal+external)
|
||||
|
||||
;; tests using module-boundary contracts
|
@ -0,0 +1,3 @@
|
||||
#lang racket/base
|
||||
|
||||
(define included-symbol 'bar)
|
@ -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…
Reference in New Issue