|
|
|
|
|
#lang racket/base
|
|
|
|
|
|
(require (for-syntax racket/base racket/syntax))
|
|
|
|
|
|
(require net/url xml racket/set)
|
|
|
|
|
|
(require "../len.rkt" "../define/provide.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)]
|
|
|
|
|
|
[else (len x)])))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide (->string x)
|
|
|
|
|
|
(if (string? x)
|
|
|
|
|
|
x ; fast exit for strings
|
|
|
|
|
|
(with-handlers ([exn:fail? (make-coercion-error-handler 'string x)])
|
|
|
|
|
|
(cond
|
|
|
|
|
|
[(equal? '() 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
|
|
|
|
|
|
[(vector? x) (vector->list x)]
|
|
|
|
|
|
[(set? x) (set->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)
|
|
|
|
|
|
;; no point to having list and vector here; they work with everything
|
