parent
90f7eef3e8
commit
2c59ab3974
@ -1,17 +1,24 @@
|
|||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require (for-syntax racket/base) "define.rkt")
|
(require (for-syntax racket/base) "define.rkt")
|
||||||
|
|
||||||
|
|
||||||
(define+provide+safe (make-caching-proc base-proc)
|
(define+provide+safe (make-caching-proc base-proc)
|
||||||
(procedure? . -> . procedure?)
|
(procedure? . -> . procedure?)
|
||||||
(let ([cache (make-hash)])
|
(let ([cache (make-hash)])
|
||||||
(make-keyword-procedure
|
(make-keyword-procedure
|
||||||
(λ (kws kw-args . args)
|
(λ (kws kw-args . args)
|
||||||
(hash-ref! cache args (λ () (keyword-apply base-proc kws kw-args args)))))))
|
(hash-ref! cache (list* kws kw-args args) (λ () (keyword-apply base-proc kws kw-args args)))))))
|
||||||
|
|
||||||
|
|
||||||
|
(define-for-syntax (lambdafy stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ (id arg ... . rest-arg) body ...)
|
||||||
|
#'(id (λ (arg ... . rest-arg) body ...))]
|
||||||
|
[(_ id body-exp)
|
||||||
|
#'(id body-exp)]))
|
||||||
|
|
||||||
|
|
||||||
(provide+safe define/caching)
|
(provide+safe define/caching)
|
||||||
(define-syntax (define/caching stx)
|
(define-syntax (define/caching stx)
|
||||||
(syntax-case stx ()
|
(with-syntax ([(id lambda-expr) (lambdafy stx)])
|
||||||
[(_ (name arg ... . rest-arg) body ...)
|
#'(define id (make-caching-proc lambda-expr))))
|
||||||
#'(define/caching name (λ(arg ... . rest-arg) body ...))]
|
|
||||||
[(_ name body ...)
|
|
||||||
#'(define name (make-caching-proc body ...))]))
|
|
||||||
|
@ -1,165 +1,12 @@
|
|||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require (for-syntax racket/base racket/syntax))
|
|
||||||
(require net/url racket/set racket/sequence "unstable/len.rkt" "define.rkt")
|
|
||||||
|
|
||||||
(define-syntax-rule (make-coercion-error-handler target-format x)
|
(define-syntax-rule (r+p modname ...)
|
||||||
(λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format))))
|
(begin
|
||||||
|
(begin
|
||||||
|
(require modname)
|
||||||
|
(provide (all-from-out modname))
|
||||||
|
(module+ safe
|
||||||
|
(require (submod modname safe))
|
||||||
|
(provide (all-from-out (submod modname safe))))) ...))
|
||||||
|
|
||||||
|
(r+p "coerce/base.rkt" "coerce/contract.rkt")
|
||||||
(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) (bytes? 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)]
|
|
||||||
[(or (char? x) (bytes? 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)
|
|
@ -0,0 +1,119 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require (for-syntax racket/base racket/syntax))
|
||||||
|
(require net/url racket/sequence "../unstable/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) (bytes? 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 (null? x) (void? x)) ""]
|
||||||
|
[(symbol? x) (symbol->string x)]
|
||||||
|
[(number? x) (number->string x)]
|
||||||
|
[(path? x) (path->string x)]
|
||||||
|
[(or (char? x) (bytes? 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)]
|
||||||
|
;; 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))
|
||||||
|
|
||||||
|
|
||||||
|
(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)
|
@ -0,0 +1,44 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require (for-syntax racket/base racket/syntax) racket/contract "../define.rkt" "base.rkt")
|
||||||
|
|
||||||
|
|
||||||
|
(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)
|
@ -1,7 +1,7 @@
|
|||||||
#lang info
|
#lang info
|
||||||
(define collection "sugar")
|
(define collection "sugar")
|
||||||
(define version "0.1")
|
(define version "0.2")
|
||||||
(define deps '("base" "rackunit-lib"))
|
(define deps '("base"))
|
||||||
(define build-deps '("scribble-lib" "racket-doc"))
|
(define build-deps '("scribble-lib" "racket-doc"))
|
||||||
(define scribblings '(("scribblings/sugar.scrbl" ())))
|
(define scribblings '(("scribblings/sugar.scrbl" ())))
|
||||||
(define compile-omit-paths '("test"))
|
(define compile-omit-paths '("test"))
|
@ -1,18 +1,19 @@
|
|||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(define-syntax-rule (r+p modname)
|
(define-syntax-rule (r+p modname ...)
|
||||||
|
(begin
|
||||||
(begin
|
(begin
|
||||||
(require modname)
|
(require modname)
|
||||||
(provide (all-from-out modname))
|
(provide (all-from-out modname))
|
||||||
(module+ safe
|
(module+ safe
|
||||||
(require (submod modname safe))
|
(require (submod modname safe))
|
||||||
(provide (all-from-out (submod modname safe))))))
|
(provide (all-from-out (submod modname safe))))) ...))
|
||||||
|
|
||||||
(r+p "cache.rkt")
|
(r+p "cache.rkt"
|
||||||
(r+p "coerce.rkt")
|
"coerce.rkt"
|
||||||
(r+p "debug.rkt")
|
"debug.rkt"
|
||||||
(r+p "define.rkt")
|
"define.rkt"
|
||||||
(r+p "file.rkt")
|
"file.rkt"
|
||||||
(r+p "list.rkt")
|
"list.rkt"
|
||||||
(r+p "test.rkt")
|
"test.rkt"
|
||||||
(r+p "xml.rkt")
|
"xml.rkt")
|
Loading…
Reference in New Issue