PasteRack.org
Paste # 78890
2016-04-25 11:03:50

Fork as a new paste.

Paste viewed 116 times.


Embed:

Contract erra

  1. #lang racket/base
  2. (require racket/contract/base
  3.          racket/contract/combinator)
  4.  
  5. (struct Expr (ty))
  6.  
  7. (define (Expr?/c ty?)
  8.   (make-flat-contract
  9.    #:first-order Expr?
  10.    #:projection
  11.    (λ (b)
  12.      (λ (x)
  13.        (if (Expr? x)
  14.            (let ([xt (Expr-ty x)])
  15.              (if (ty? xt)
  16.                  x
  17.                  (raise-blame-error
  18.                   b x
  19.                   '(expected: "~a" given: "Expr(~e) with type ~a")
  20.                   ty? x xt)))
  21.            (raise-blame-error
  22.             b x
  23.             '(expected: "~a" given: "~e")
  24.             ty? x))))))
  25.  
  26. (define Int? (λ (x) (eq? x 'Int)))
  27. (define Ptr? (λ (x) (eq? x 'Ptr)))
  28. (define Int/c (Expr?/c Int?))
  29. (define Ptr/c (Expr?/c Ptr?))
  30. (define A (Expr 'Array))
  31.  
  32. (module+ test
  33.   (with-handlers ([exn:fail? (λ (x) (exn-message x))])
  34.     (contract Int/c A 'pos 'neg))
  35.   (with-handlers ([exn:fail? (λ (x) (exn-message x))])
  36.     (contract Ptr/c A 'pos 'neg))
  37.   (with-handlers ([exn:fail? (λ (x) (exn-message x))])
  38.     (contract (or/c Int/c Ptr/c) A 'pos 'neg)))

=>