Coverage report: /home/runner/work/geb/geb/test/geb-trans.lisp

KindCoveredAll%
expression80107 74.8
branch00nil
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb-test)
2
 
3
 (define-test geb.trans :parent geb-test-suite)
4
 
5
 (def geb.pair-of-size-4
6
   (to-bitc
7
    (pair (->right so1 bool)
8
          (->left so1 bool))))
9
 
10
 (define-test geb.trans-pair :parent geb.trans
11
   (is = 4 (codom geb.pair-of-size-4)
12
       "both objects have max size of 2, pair them size 4")
13
   (is = 1 (dom   geb.pair-of-size-4)
14
       "Our input is bool, thus 1 bit")
15
   (is obj-equalp #*1100 (gapply geb.pair-of-size-4 #*1)
16
       "Right should tag it with 1, with our 1 injected and our left should
17
        always be 00")
18
   (is obj-equalp #*1000 (gapply geb.pair-of-size-4 #*0)
19
       "Right should tag it with 1, with our 0 injected and our left should
20
        always be 00"))
21
 
22
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23
 ;;                    Interpreter tests                      ;;
24
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
 
26
 (define-test geb.trans-eval :parent geb.trans)
27
 
28
 (def bitc-yes
29
   (gapply (to-bitc dec:inj-yes) #*))
30
 
31
 (def bitc-no
32
   (gapply (to-bitc dec:inj-no) #*))
33
 
34
 (def bitc-maybe
35
   (gapply (to-bitc dec:inj-maybe) #*))
36
 
37
 (defun bitc-pair (&rest morphisms)
38
   "pairs the constructors and then calls bitc. only with constructors"
39
   (gapply (to-bitc (apply #'pair morphisms)) #*))
40
 
41
 (define-test geb.trans-eval-maybe :parent geb.trans-eval
42
   ;; merge tests
43
   (is equalp
44
       bitc-yes
45
       (gapply (to-bitc dec:merge-opinion)
46
               (bitc-pair dec:inj-maybe dec:inj-yes)))
47
   (is equalp
48
       bitc-maybe
49
       (gapply (to-bitc dec:merge-opinion)
50
               (bitc-pair dec:inj-no dec:inj-yes)))
51
   (is equalp
52
       bitc-no
53
       (gapply (to-bitc dec:merge-opinion)
54
               (bitc-pair dec:inj-no dec:inj-maybe)))
55
   (is equalp
56
       bitc-no
57
       (gapply (to-bitc dec:merge-opinion)
58
               (bitc-pair dec:inj-maybe dec:inj-no)))
59
 
60
   ;; promote and demote tests
61
   (is equalp bitc-no    (gapply (to-bitc dec:demote) bitc-no))
62
   (is equalp bitc-no    (gapply (to-bitc dec:demote) bitc-maybe))
63
   (is equalp bitc-maybe (gapply (to-bitc dec:demote) bitc-yes))
64
   (is equalp bitc-yes   (gapply (to-bitc dec:promote) bitc-yes))
65
   (is equalp bitc-yes   (gapply (to-bitc dec:promote) bitc-maybe))
66
   (is equalp bitc-maybe (gapply (to-bitc dec:promote) bitc-no)))