~nytpu/dbc-scheme

dbc-scheme/contracts-test.scm -rwxr-xr-x 3.2 KiB
c2dccf9anytpu add license file 7 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
#!/usr/bin/env chibi-scheme
;;; dbc-test.scm --- tests for (nytpu contracts)
;;;
;;; Copyright (c) 2022 nytpu <alex [at] nytpu.com>
;;; SPDX-License-Identifier: MPL-2.0
;;; Home Page: <https://git.sr.ht/~nytpu/dbc-scheme>

(import (scheme base)
        (srfi 1)
        (srfi 64))

(import (scheme lazy)) (include "contracts.scm")
#;(import (nytpu contracts))

(test-begin "(nytpu contracts)")

(test-begin "define-contract")
(define-contract (add-map . lists)
  (pre (>= (length lists) 2)
       (every list? lists)
       (apply = (map length lists))
       (every (lambda (x) (every number? x)) lists))
  (post list?
        (lambda (ret) (every number? ret))
        (lambda (ret) (= (length ret) (length (car lists)))))
  (apply map + lists))
(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
            '(5 5 5 5))
(test-equal (add-map '(1 2 3) '(1 2 3) '(1 2 3))
            '(3 6 9))
(test-error (add-map '(1 2 3 4)))
(test-error (add-map '(1 2 3 4) 4))
(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
(test-end "define-contract")

(test-begin "lambda-contract")
(set! add-map #f)
(define add-map
  (lambda-contract lists
    (pre (>= (length lists) 2)
         (every list? lists)
         (apply = (map length lists))
         (every (lambda (x) (every number? x)) lists))
    (post list?
          (lambda (ret) (every number? ret))
          (lambda (ret) (= (length ret) (length (car lists)))))
    (apply map + lists)))
(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
            '(5 5 5 5))
(test-equal (add-map '(1 2 3) '(1 2 3) '(1 2 3))
            '(3 6 9))
(test-error (add-map '(1 2 3 4)))
(test-error (add-map '(1 2 3 4) 4))
(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
(test-end "lambda-contract")

(test-begin "define-contract alternates")
(define-contract (add-map . lists)
  (pre (>= (length lists) 2)
       (every list? lists)
       (apply = (map length lists))
       (every (lambda (x) (every number? x)) lists))
  "hello, world!")
(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
            "hello, world!")
(test-equal (add-map '(1 2 3) '(1 2 3) '(1 2 3))
            "hello, world!")
(test-error (add-map '(1 2 3 4)))
(test-error (add-map '(1 2 3 4) 4))
(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))

(define-contract (add-map . lists)
  (post list?
        (lambda (ret) (every number? ret))
        (lambda (ret) (= (length ret) (length (car lists)))))
  "hello, world!")
(test-error (add-map '(1 2 3 4) '(4 3 2 1)))
(test-error (add-map '(1 2 3) '(1 2 3) '(1 2 3)))
(test-error (add-map '(1 2 3 4)))
(test-error (add-map '(1 2 3 4) 4))
(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))

(define-contract (add-map list1 list2)
  (pre (and (list? list1) (list? list2))
       (= (length list1) (length list2))
       (every (lambda (x) (every number? x)) (list list1 list2)))
  (post list?
        (lambda (ret) (every number? ret))
        (lambda (ret) (= (length ret) (length list1))))
  (map + list1 list2))
(test-equal (add-map '(1 2 3 4) '(4 3 2 1))
            '(5 5 5 5))
(test-equal (add-map '(1 2 3) '(1 2 3))
            '(2 4 6))
(test-error (add-map '(1 2 3 4)))
(test-error (add-map '(1 2 3 4) 4))
(test-error (add-map '(1 2 3 4) '(3 2 bazinga)))
(test-end "define-contract alternates")

(test-end "(nytpu contracts)")