updates

coerce.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 (require racket/contract net/url xml racket/set)
 (module+ test (require rackunit))
-(require "len.rkt" "exception.rkt")
+(require "len.rkt" "exception.rkt" "define.rkt")
 
 (provide (contract-out
           [->int (any/c . -> . integer?)]
@@ -16,77 +16,121 @@
 
 ;; general way of coercing to integer
 (define (->int x)
-  (cond
+  (try 
-    [(integer? x) x]
+   (cond
-    [(real? x) (floor x)]
+     [(or (integer? x) (real? x)) (inexact->exact (floor x))] 
-    [(and (string? x) (> (len x) 0)) (->int (string->number x))]
+     [(and (string? x) (> (len x) 0)) (->int (string->number x))]
-    [(symbol? x) (->int (->string x))]
+     [(symbol? x) (->int (->string x))]
-    [(char? x) (char->integer x)]
+     [(char? x) (char->integer x)]
-    [else (try (len x) (except [exn:fail? (λ(e) (error "Can't convert to integer:" x))]))]))
+     [else (len x)])
+   (except [exn:fail? (λ(e) (error "Can't convert to integer:" x))])))
+
 
 
 ;; general way of coercing to string
 (define (->string x)
-  (cond 
+  (try 
-    [(string? x) x]
+   (cond 
-    [(equal? '() x) ""]
+     [(string? x) x]
-    [(symbol? x) (symbol->string x)]
+     [(equal? '() x) ""]
-    [(number? x) (number->string x)]
+     [(symbol? x) (symbol->string x)]
-    [(url? x) (->string (->path x))] ; todo: a url is more than just a path-string ... it has character encoding issues
+     [(number? x) (number->string x)]
-    [(path? x) (path->string x)]
+     [(url? x) (->string (->path x))] ; todo: a url is more than just a path-string ... it has character encoding issues
-    [(char? x) (format "~a" x)]
+     [(path? x) (path->string x)]
-    [(xexpr? x) (xexpr->string x)] ; put this last so other xexprish things don't get caught
+     [(char? x) (format "~a" x)]
-    [else (error (format "Can't make ~a into string" x))]))
+     [else (error)]) ; put this last so other xexprish things don't get caught
+   (except [exn:fail? (λ(e) (error (format "Can't make ~a into string" x)))])))
 
 
 ;; general way of coercing to symbol
-(define (->symbol thing)
+(define (->symbol x)
-  ; todo: on bad input, it will pop a string error rather than symbol error
+  (try (string->symbol (->string x)) 
-  (string->symbol (->string thing))) 
+       (except [exn:fail? (λ(e) (error (format "Can't make ~a into symbol" x)))])))
 
 ;; general way of coercing to path
-(define (->path thing)
+(define (->path x)
-  ; todo: on bad input, it will pop a string error rather than path error
+  (try
-  (cond 
+   (cond 
-    [(url? thing) (apply build-path (map path/param-path (url-path thing)))]
+     [(url? x) (apply build-path (map path/param-path (url-path x)))]
-    [else (string->path (->string thing))]))
+     [else (string->path (->string x))])
+   (except [exn:fail? (λ(e) (error (format "Can't make ~a into path" x)))])))
 
 
 ;; general way of coercing to url
-(define (->url thing)
+(define (->url x)
-  ; todo: on bad input, it will pop a string error rather than url error
+  (try (string->url (->string x))
-  (string->url (->string thing)))
+       (except [exn:fail? (λ(e) (error (format "Can't make ~a into url" x)))])))
 
-(define (->complete-path thing)
+(define (->complete-path x)
-  (path->complete-path (->path thing)))
+  (try (path->complete-path (->path x))
+       (except [exn:fail? (λ(e) (error (format "Can't make ~a into complete-path" x)))])))
 
 
 ;; general way of coercing to a list
 (define (->list x)
-  (cond 
+  (try
-    [(list? x) x]
+   (cond 
-    [(vector? x) (vector->list x)]
+     [(list? x) x]
-    [(set? x) (set->list x)]
+     [(vector? x) (vector->list x)]
-    [else (list x)])) 
+     [(set? x) (set->list x)]
-
+     [else (list x)])
+   (except [exn:fail? (λ(e) (error (format "Can't make ~a into list" x)))])))
 
 
 ;; general way of coercing to vector
 (define (->vector x)
-  ; todo: on bad input, it will pop a list error rather than vector error
+  (try
-  (cond
+   (cond
-    [(vector? x) x]
+     [(vector? x) x]
-    [else (list->vector (->list x))]))
+     [else (list->vector (->list x))])
+   (except [exn:fail? (λ(e) (error (format "Can't make ~a into vector" x)))])))
 
 
 
 ;; general way of coercing to boolean
 (define (->boolean x)
-  ;; in Racket, everything but #f is true
+  (try
-  (if x #t #f))
+   (if x #t #f)
-
+   (except [exn:fail? (λ(e) (error (format "Can't make ~a into boolean" x)))])))
-
+
-
+
-
+;;
-
+;; Coercion contracts
+;;
+
+(define-syntax-rule (make-blame-handler try-proc expected-sym)
+  (λ (b)
+    (λ (x)
+      (try (try-proc x)
+           (except [exn:fail? (λ(e)
+                                (raise-blame-error
+                                 b x
+                                 '(expected: "~a" given: "~e")
+                                 expected-sym x))])))))
+
+
+(define/provide coerce/integer?
+  (make-contract
+   #:name 'coerce/integer?
+   #:projection (make-blame-handler ->int 'can-be-integer?)))
+
+(define/provide coerce/string?
+  (make-contract
+   #:name 'coerce/string?
+   #:projection (make-blame-handler ->string 'can-be-string?)))
+
+(define/provide coerce/symbol?
+  (make-contract
+   #:name 'coerce/symbol?
+   #:projection (make-blame-handler ->symbol 'can-be-symbol?)))
+
+(define/provide coerce/path?
+  (make-contract
+   #:name 'coerce/path?
+   #:projection (make-blame-handler ->path 'can-be-path?)))
+
+(define/provide coerce/boolean?
+  (make-contract
+   #:name 'coerce/boolean?
+   #:projection (make-blame-handler ->boolean 'can-be-boolean?)))
 

define.rkt

@@ -0,0 +1,46 @@
+#lang racket/base
+(require (for-syntax racket/base))
+(require racket/contract)
+
+
+(provide define/provide define/provide/contract)
+
+;; todo: these won't handle nested forms like (define ((foo x) y))
+
+(define-syntax (define/provide stx)
+  (syntax-case stx ()
+    ;; order of cases matters, of course
+    ;; match more complicated shape first, 
+    ;; otherwise second matcher gives false positives
+    [(_ (name arg ...) body ...)
+     #'(begin
+         (provide name)
+         (define (name arg ...) body ...))]
+    [(_ (name . arg) body ...)
+     #'(begin
+         (provide name)
+         (define (name . arg) body ...))]
+    [(_ name body ...)
+     #'(begin
+         (provide name)
+         (define name body ...))]))
+
+
+(define-syntax (define/provide/contract stx)
+  (syntax-case stx ()
+    [(_ (name arg ...) contract body ...)
+     #'(begin
+         (provide (contract-out [name contract]))
+         (define (name arg ...) body ...))]
+    [(_ (name . arg) contract body ...)
+     #'(begin
+         (provide (contract-out [name contract]))
+         (define (name . arg) body ...))]
+    [(_ name contract body ...)
+     #'(begin
+         (provide (contract-out [name contract]))
+         (define name body ...))]))
+
+(define/provide/contract (foo #:what x)
+  (#:what integer? . -> . integer?)
+  (λ(x) x))

exception.rkt

@@ -9,4 +9,3 @@
      [(_ body ... (except tests ...))
       #'(with-handlers (tests ...) body ...)]))
 
-

main.rkt

@@ -4,6 +4,7 @@
   "coerce.rkt"
   "container.rkt"
   "debug.rkt"
+  "define.rkt"
   "list.rkt"
   "misc.rkt"
   "string.rkt"
@@ -16,6 +17,7 @@
   "coerce.rkt"
   "container.rkt"
   "debug.rkt"
+  "define.rkt"
   "list.rkt"
   "misc.rkt"
   "string.rkt"

tests.rkt

@@ -11,7 +11,6 @@
 (define file-name-as-text "foo.txt")
 (check-equal? (->string (string->path file-name-as-text)) file-name-as-text)
 (check-equal? (->string #\¶) "¶")
-(check-equal? (->string '(foo "bar")) "<foo>bar</foo>")