PasteRack.org
Paste # 67540
2014-09-22 09:12:58

Fork as a new paste.

Paste viewed 441 times.


Embed:

super generic function contract

  1. #lang racket/base
  2. (require racket/contract/base
  3.          racket/contract/combinator)
  4.  
  5. (define (gen->/c in/c in->out/c)
  6.   (define b->inp (contract-projection in/c))
  7.   (make-contract
  8.    #:first-order procedure?
  9.    #:projection
  10.    (lambda (b)
  11.      (define inp (b->inp (blame-swap b)))
  12.      (lambda (x)
  13.        (lambda args
  14.          (define args/c (inp args))
  15.          (call-with-values (lambda () (apply x args/c))
  16.            (lambda res
  17.              (define out/c (in->out/c args/c))
  18.              (define b->outp (contract-projection out/c))
  19.              (define outp (b->outp b))
  20.              (apply values (outp res)))))))))
  21.  
  22. (module+ test
  23.   (require racket/list
  24.            rackunit)
  25.  
  26.   (define (f x)
  27.     (if (= x 7)
  28.       17
  29.       (apply values
  30.              (for/list ([i (in-range x)])
  31.                i))))
  32.  
  33.   (define f/c
  34.     (contract
  35.      (gen->/c (list/c number?)
  36.               (λ (l)
  37.                 (λ (out) (and (list? out)
  38.                               (= (length out) (first l))
  39.                               (andmap number? out)))))
  40.      f
  41.      'f
  42.      'test))
  43.  
  44.   (displayln "Example 1")
  45.   (f/c 5)
  46.   (displayln "Example 2")
  47.   (thread-wait (thread (λ () (f/c "foo"))))
  48.   (displayln "Example 3")
  49.   (thread-wait (thread (λ () (f/c 7)))))

=>