From 569b3d4453ca3ac7c90b2f6c3b07637691daf902 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 4 Aug 2017 13:27:21 -0700 Subject: [PATCH] refactor coercions with generics --- sugar/coerce/base.rkt | 204 +++++++++++++++++++++-------------------- sugar/unstable/len.rkt | 42 ++++++--- 2 files changed, 133 insertions(+), 113 deletions(-) diff --git a/sugar/coerce/base.rkt b/sugar/coerce/base.rkt index 4dccdb8..0ece376 100644 --- a/sugar/coerce/base.rkt +++ b/sugar/coerce/base.rkt @@ -1,119 +1,121 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax)) -(require net/url racket/sequence "../unstable/len.rkt" "../define.rkt") +(require (for-syntax + 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) - (λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format)))) +(module+ safe (require racket/contract)) +(define-syntax-rule (make-coercion-error-handler func funcish val) + (λ (exn) (raise-argument-error 'func (symbol->string 'funcish) val))) -(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) +(define (disjoin . preds) (λ (x) (ormap (λ (pred) (pred x)) preds))) +(define identity (λ (x) x)) + +(define-generics+provide+safe stringish (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) + (->string stringish) + #:fast-defaults + ([string? (define ->string identity)] + [(disjoin null? void?) (define (->string x) "")] + [symbol? (define ->string symbol->string)] + [number? (define ->string number->string)] + [path? (define ->string path->string)] + [(disjoin char? bytes?) (define (->string x) (format "~a" x))] + [url? (define ->string url->string)])) + + +(define (real->int x) (inexact->exact (floor x))) +(define (string->int x) (let ([strnum (string->number x)]) + (unless (real? strnum) + (raise-argument-error '->int "eligible string" x)) + (real->int strnum))) + +(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?) - (if (symbol? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) - (string->symbol (->string x))))) + (->symbol symbolish) + #:fast-defaults + ([symbol? (define ->symbol identity)] + [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?) - (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) + (->path pathish) + #:fast-defaults + ([path? (define ->path identity)] + [stringish? (define (->path x) + (with-handlers ([exn:fail? (make-coercion-error-handler ->path pathish? x)]) + (if (url? x) + (apply build-path (map path/param-path (url-path x))) + (string->path (->string x)))))])) + + +(define-generics+provide+safe urlish + (any/c . -> . url?) + (->url urlish) + #: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-generics+provide+safe complete-pathish (any/c . -> . complete-path?) - (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) - (path->complete-path (->path x)))) + (->complete-path complete-pathish) + #: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?) - (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) + (->list listish) + #:fast-defaults + ([list? (define ->list identity)] + [string? (define ->list list)] + [vector? (define ->list vector->list)] + [hash? (define ->list hash->list)] + [integer? (define ->list list)] + [sequence? (define ->list sequence->list)] + [stream? (define ->list stream->list)] + [(λ (x) #t) (define ->list list)])) + + +(define-generics+provide+safe vectorish (any/c . -> . vector?) - (if (vector? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) - (list->vector (->list x))))) + (->vector vectorish) + #:fast-defaults + ([vector? (define ->vector identity)] + [listish? (define (->vector x) + (with-handlers ([exn:fail? (make-coercion-error-handler ->vector vectorish? 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) \ No newline at end of file + (and x #t)) \ No newline at end of file diff --git a/sugar/unstable/len.rkt b/sugar/unstable/len.rkt index 516e178..aae03a4 100644 --- a/sugar/unstable/len.rkt +++ b/sugar/unstable/len.rkt @@ -1,17 +1,35 @@ #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?) - (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))] - [(and (sequence? x) (not (integer? x))) (len (sequence->list x))] - [else (error "len: can't calculate length of" x)])) + +(provide define-generics+provide+safe) +(define-syntax (define-generics+provide+safe stx) + (syntax-case stx () + [(_ TYPE ID-CONTRACT (ID . ID-ARGS) . ARGS) + (with-syntax ([TYPE? (format-id stx "~a?" #'TYPE)]) + #'(begin + (provide TYPE? ID) + (module+ safe + (require racket/contract) + (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