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

refactor coercions with generics

Browse Source
dev-refac-2020
Matthew Butterick 7 years ago
parent e7126511cf
commit 569b3d4453
2 changed files with 133 additions and 113 deletions
Show Stats Download Patch File Download Diff File

192
sugar/coerce/base.rkt
Unescape Escape View File

@ -1,119 +1,121 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base racket/syntax)) (require (for-syntax
(require net/url racket/sequence "../unstable/len.rkt" "../define.rkt") racket/base
racket/syntax)
racket/stream
racket/generic
net/url
racket/sequence
"../unstable/len.rkt"
"../define.rkt")
(define-syntax-rule (make-coercion-error-handler target-format x) (module+ safe (require racket/contract))
(λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format))))
(define-syntax-rule (make-coercion-error-handler func funcish val)
(λ (exn) (raise-argument-error 'func (symbol->string 'funcish) val)))
(define+provide+safe (->int x) (define (disjoin . preds) (λ (x) (ormap (λ (pred) (pred x)) preds)))
(any/c . -> . integer?) (define identity (λ (x) x))
(with-handlers ([exn:fail? (make-coercion-error-handler 'int x)])
(cond (define-generics+provide+safe stringish
[(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?) (any/c . -> . string?)
(if (string? x) (->string stringish)
x ; fast exit for strings #:fast-defaults
(with-handlers ([exn:fail? (make-coercion-error-handler 'string x)]) ([string? (define ->string identity)]
(cond [(disjoin null? void?) (define (->string x) "")]
[(or (null? x) (void? x)) ""] [symbol? (define ->string symbol->string)]
[(symbol? x) (symbol->string x)] [number? (define ->string number->string)]
[(number? x) (number->string x)] [path? (define ->string path->string)]
[(path? x) (path->string x)] [(disjoin char? bytes?) (define (->string x) (format "~a" x))]
[(or (char? x) (bytes? x)) (format "~a" x)] [url? (define ->string url->string)]))
[(url? x) (url->string x)]
[else (error 'bad-type)]))))
(define (real->int x) (inexact->exact (floor x)))
(define (string->int x) (let ([strnum (string->number x)])
;; ->symbol, ->path, and ->url are just variants on ->string (unless (real? strnum)
;; two advantages: return correct type, and more accurate error (raise-argument-error '->int "eligible string" x))
(real->int strnum)))
;; no need for "Symbolable" type - same as Stringable
(define+provide+safe (->symbol x) (define-generics+provide+safe intish
(any/c . -> . integer?)
(->int intish)
#:fast-defaults
([(disjoin integer? real?) (define ->int real->int)]
[complex? (define ->int (compose1 real->int real-part))]
[string? (define ->int string->int)]
[(disjoin symbol? path? bytes?) (define ->int (compose1 string->int ->string))]
[char? (define ->int char->integer)]
[lengthable? (define (->int x)
(with-handlers ([exn:fail? (make-coercion-error-handler ->int intish? x)])
(len x)))]))
(define-generics+provide+safe symbolish
(any/c . -> . symbol?) (any/c . -> . symbol?)
(if (symbol? x) (->symbol symbolish)
x #:fast-defaults
(with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) ([symbol? (define ->symbol identity)]
(string->symbol (->string x))))) [stringish? (define (->symbol x)
(with-handlers ([exn:fail? (make-coercion-error-handler ->symbol symbolish? x)])
(string->symbol (->string x))))]))
(define+provide+safe (->path x) (define-generics+provide+safe pathish
(any/c . -> . path?) (any/c . -> . path?)
(if (path? x) (->path pathish)
x #:fast-defaults
(with-handlers ([exn:fail? (make-coercion-error-handler 'path x)]) ([path? (define ->path identity)]
(cond [stringish? (define (->path x)
[(url? x) (apply build-path (map path/param-path (url-path x)))] (with-handlers ([exn:fail? (make-coercion-error-handler ->path pathish? x)])
[else (string->path (->string x))])))) (if (url? x)
(apply build-path (map path/param-path (url-path x)))
(string->path (->string x)))))]))
(define+provide+safe (->url x) (define-generics+provide+safe urlish
(any/c . -> . url?) (any/c . -> . url?)
(with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) (->url urlish)
(string->url (->string x)))) #:fast-defaults
([url? (define ->url identity)]
[stringish? (define (->url x)
(with-handlers ([exn:fail? (make-coercion-error-handler ->url urlish? x)])
(string->url (->string x))))]))
(define+provide+safe (->complete-path x) (define-generics+provide+safe complete-pathish
(any/c . -> . complete-path?) (any/c . -> . complete-path?)
(with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) (->complete-path complete-pathish)
(path->complete-path (->path x)))) #:fast-defaults
([complete-path? (define ->complete-path identity)]
[stringish? (define (->complete-path x)
(with-handlers ([exn:fail? (make-coercion-error-handler ->complete-path complete-pathish? x)])
(path->complete-path (->path x))))]))
(define+provide+safe (->list x) (define-generics+provide+safe listish
(any/c . -> . list?) (any/c . -> . list?)
(if (list? x) (->list listish)
x #:fast-defaults
(with-handlers ([exn:fail? (make-coercion-error-handler 'list x)]) ([list? (define ->list identity)]
(cond [string? (define ->list list)]
[(string? x) (list x)] [vector? (define ->list vector->list)]
[(vector? x) (for/list ([i (in-vector x)]) [hash? (define ->list hash->list)]
i)] [integer? (define ->list list)]
;; conditional sequencing relevant because hash also tests true for `sequence?` [sequence? (define ->list sequence->list)]
[(hash? x) (hash->list x)] [stream? (define ->list stream->list)]
[(integer? x) (list x)] ; because an integer tests #t for sequence? [(λ (x) #t) (define ->list list)]))
[(sequence? x) (sequence->list x)]
;[(stream? x) (stream->list x)] ;; no support for streams in TR
[else (list x)])))) (define-generics+provide+safe vectorish
(define+provide+safe (->vector x)
(any/c . -> . vector?) (any/c . -> . vector?)
(if (vector? x) (->vector vectorish)
x #:fast-defaults
(with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) ([vector? (define ->vector identity)]
(list->vector (->list x))))) [listish? (define (->vector x)
(with-handlers ([exn:fail? (make-coercion-error-handler ->vector vectorish? x)])
(list->vector (->list x))))]))
(define+provide+safe (->boolean x) (define+provide+safe (->boolean x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(and x #t)) (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)

42
sugar/unstable/len.rkt
Unescape Escape View File

@ -1,17 +1,35 @@
#lang racket/base #lang racket/base
(require "../define.rkt" racket/sequence) (require (for-syntax
racket/base
racket/syntax)
"../define.rkt"
racket/sequence
racket/generic)
(define+provide+safe (len x)
((or/c list? vector? sequence? string? symbol? path? hash?) . -> . integer?) (provide define-generics+provide+safe)
(cond (define-syntax (define-generics+provide+safe stx)
[(list? x) (length x)] (syntax-case stx ()
[(string? x) (string-length x)] [(_ TYPE ID-CONTRACT (ID . ID-ARGS) . ARGS)
[(symbol? x) (len (symbol->string x))] (with-syntax ([TYPE? (format-id stx "~a?" #'TYPE)])
[(path? x) (len (path->string x))] #'(begin
[(vector? x) (vector-length x)] (provide TYPE? ID)
[(hash? x) (len (hash-keys x))] (module+ safe
[(and (sequence? x) (not (integer? x))) (len (sequence->list x))] (require racket/contract)
[else (error "len: can't calculate length of" x)])) (provide TYPE? (contract-out [ID ID-CONTRACT])))
(define-generics TYPE (ID . ID-ARGS) . ARGS)))]))
(provide len lengthable?)
(define-generics lengthable
(len lengthable)
#:fast-defaults
([list? (define len length)]
[string? (define len string-length)]
[symbol? (define len (compose1 string-length symbol->string))]
[path? (define len (compose1 string-length path->string))]
[vector? (define len vector-length)]
[hash? (define (len x) (length (hash-keys x)))]
[(λ (x) (and (sequence? x) (not (integer? x)))) (define len (compose1 length sequence->list))]))
(module+ test (module+ test

Write Preview
Loading…
Cancel
Save