canonicalize.rkt

#lang racket

(provide
 (contract-out
  [canonicalize/c
   (-> (-> any/c any/c) contract?)]))

(module+ test (require rackunit))

(define (canonicalize/c convert)
  (define convert-name (object-name convert))
  (make-contract
   #:name `(canonicalize/c ,convert-name)
   #:first-order convert
   #:late-neg-projection
   (λ (blm)
     (λ (val neg)
       (define result (convert val))
       (unless result
         (raise-blame-error
          #:missing-party neg
          blm val
          '(expected: "~a" given: "~e")
          convert-name val))
       result))))

(module+ test
  (define (string->path/f x)
    (and (string? x) (string->path x)))

  (define/contract (f x)
    (-> (or/c path? (canonicalize/c string->path/f)) any)
    (path? x))

  (check-true (f (build-path ".")))
  (check-true (f "/home/user/test.txt"))
  (check-exn exn:fail:contract? (λ () (f 42)))

  (define (natural->string/f n)
    (and (natural? n) (~a n)))

  (define/contract (g x)
         (-> (canonicalize/c natural->string/f) any)
    (string? x))

  (check-true (g 42))
  (check-exn exn:fail:contract? (λ () (g "hi"))))