Wider.hs (7078B)
1 {-# OPTIONS_GHC -fno-warn-orphans #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE NumericUnderscores #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 7 module Wider ( 8 tests 9 ) where 10 11 import qualified Data.Choice as C 12 import qualified Data.Word.Wider as W 13 import qualified GHC.Num.Integer as I 14 import Test.Tasty 15 import qualified Test.Tasty.HUnit as H 16 import qualified Test.Tasty.QuickCheck as Q 17 18 overflowing_add_no_carry :: H.Assertion 19 overflowing_add_no_carry = do 20 let !(r, c) = W.add_o 1 0 21 H.assertBool mempty (W.eq_vartime r 1) 22 H.assertBool mempty (c == 0) 23 24 overflowing_add_with_carry :: H.Assertion 25 overflowing_add_with_carry = do 26 let !(r, c) = W.add_o (2 ^ (256 :: Word) - 1) 1 27 H.assertBool mempty (W.eq_vartime r 0) 28 H.assertBool mempty (c == 1) 29 30 wrapping_add_no_carry :: H.Assertion 31 wrapping_add_no_carry = do 32 let !r = W.add 0 1 33 H.assertBool mempty (W.eq_vartime r 1) 34 35 wrapping_add_with_carry :: H.Assertion 36 wrapping_add_with_carry = do 37 let !r = W.add (2 ^ (256 :: Word) - 1) 1 38 H.assertBool mempty (W.eq_vartime r 0) 39 40 borrowing_sub_no_borrow :: H.Assertion 41 borrowing_sub_no_borrow = do 42 let !(d, b) = W.sub_b 1 1 43 H.assertBool mempty (W.eq_vartime d 0) 44 H.assertBool mempty (b == 0) 45 46 borrowing_sub_with_borrow :: H.Assertion 47 borrowing_sub_with_borrow = do 48 let !(d, b) = W.sub_b 0 1 49 H.assertBool mempty (W.eq_vartime d (2 ^ (256 :: Word) - 1)) 50 H.assertBool mempty (b == (2 ^ (64 :: Word) - 1)) 51 52 wrapping_sub_no_borrow :: H.Assertion 53 wrapping_sub_no_borrow = do 54 let !r = W.sub 1 1 55 H.assertBool mempty (W.eq_vartime r 0) 56 57 wrapping_sub_with_borrow :: H.Assertion 58 wrapping_sub_with_borrow = do 59 let !r = W.sub 0 1 60 H.assertBool mempty (W.eq_vartime r (2 ^ (256 :: Word) - 1)) 61 62 eq :: H.Assertion 63 eq = do 64 let !(W.Wider a) = 0 65 !(W.Wider b) = 2 ^ (256 :: Word) - 1 66 H.assertBool mempty (C.decide (W.eq# a a)) 67 H.assertBool mempty (not (C.decide (W.eq# a b))) 68 H.assertBool mempty (not (C.decide (W.eq# b a))) 69 H.assertBool mempty (C.decide (W.eq# b b)) 70 71 gt :: H.Assertion 72 gt = do 73 let !(W.Wider a) = 0 74 !(W.Wider b) = 1 75 !(W.Wider c) = 2 ^ (256 :: Word) - 1 76 H.assertBool mempty (C.decide (W.gt# b a)) 77 H.assertBool mempty (C.decide (W.gt# c a)) 78 H.assertBool mempty (C.decide (W.gt# c b)) 79 80 H.assertBool mempty (not (C.decide (W.gt# a a))) 81 H.assertBool mempty (not (C.decide (W.gt# b b))) 82 H.assertBool mempty (not (C.decide (W.gt# c c))) 83 84 H.assertBool mempty (not (C.decide (W.gt# a b))) 85 H.assertBool mempty (not (C.decide (W.gt# a c))) 86 H.assertBool mempty (not (C.decide (W.gt# b c))) 87 88 lt :: H.Assertion 89 lt = do 90 let !(W.Wider a) = 0 91 !(W.Wider b) = 1 92 !(W.Wider c) = 2 ^ (256 :: Word) - 1 93 H.assertBool mempty (C.decide (W.lt# a b)) 94 H.assertBool mempty (C.decide (W.lt# a c)) 95 H.assertBool mempty (C.decide (W.lt# b c)) 96 97 H.assertBool mempty (not (C.decide (W.lt# a a))) 98 H.assertBool mempty (not (C.decide (W.lt# b b))) 99 H.assertBool mempty (not (C.decide (W.lt# c c))) 100 101 H.assertBool mempty (not (C.decide (W.lt# b a))) 102 H.assertBool mempty (not (C.decide (W.lt# c a))) 103 H.assertBool mempty (not (C.decide (W.lt# c b))) 104 105 gt_vartime :: H.Assertion 106 gt_vartime = do 107 let !a = 0 108 !b = 1 109 !c = 2 ^ (256 :: Word) - 1 110 H.assertBool mempty (W.gt_vartime b a) 111 H.assertBool mempty (W.gt_vartime c a) 112 H.assertBool mempty (W.gt_vartime c b) 113 114 H.assertBool mempty (not (W.gt_vartime a a)) 115 H.assertBool mempty (not (W.gt_vartime b b)) 116 H.assertBool mempty (not (W.gt_vartime c c)) 117 118 H.assertBool mempty (not (W.gt_vartime a b)) 119 H.assertBool mempty (not (W.gt_vartime a c)) 120 H.assertBool mempty (not (W.gt_vartime b c)) 121 122 lt_vartime :: H.Assertion 123 lt_vartime = do 124 let !a = 0 125 !b = 1 126 !c = 2 ^ (256 :: Word) - 1 127 H.assertBool mempty (W.lt_vartime a b) 128 H.assertBool mempty (W.lt_vartime a c) 129 H.assertBool mempty (W.lt_vartime b c) 130 131 H.assertBool mempty (not (W.lt_vartime a a)) 132 H.assertBool mempty (not (W.lt_vartime b b)) 133 H.assertBool mempty (not (W.lt_vartime c c)) 134 135 H.assertBool mempty (not (W.lt_vartime b a)) 136 H.assertBool mempty (not (W.lt_vartime c a)) 137 H.assertBool mempty (not (W.lt_vartime c b)) 138 139 cmp :: H.Assertion 140 cmp = do 141 let !a = 0 142 !b = 1 143 !c = 2 ^ (256 :: Word) - 1 144 H.assertEqual mempty (W.cmp_vartime a b) LT 145 H.assertEqual mempty (W.cmp_vartime a c) LT 146 H.assertEqual mempty (W.cmp_vartime b c) LT 147 148 H.assertEqual mempty (W.cmp_vartime a a) EQ 149 H.assertEqual mempty (W.cmp_vartime b b) EQ 150 H.assertEqual mempty (W.cmp_vartime c c) EQ 151 152 H.assertEqual mempty (W.cmp_vartime b a) GT 153 H.assertEqual mempty (W.cmp_vartime c a) GT 154 H.assertEqual mempty (W.cmp_vartime c b) GT 155 156 sqr :: H.Assertion 157 sqr = do 158 let !n = 2 ^ (256 :: Word) - 1 159 !(l, h ) = W.sqr n 160 H.assertBool mempty (W.eq_vartime l 1) 161 H.assertBool mempty (W.eq_vartime h (n - 1)) 162 163 mul :: H.Assertion 164 mul = do 165 let !n = 2 ^ (256 :: Word) - 1 166 H.assertBool mempty (W.eq_vartime (W.mul 0 n) 0) 167 H.assertBool mempty (W.eq_vartime (W.mul n 0) 0) 168 H.assertBool mempty (W.eq_vartime (W.mul n n) 1) 169 H.assertBool mempty (W.eq_vartime (W.mul 1 n) n) 170 171 sub_mod :: H.Assertion 172 sub_mod = do 173 let !a = 0x1a2472fde50286541d97ca6a3592dd75beb9c9646e40c511b82496cfc3926956 174 !b = 0xd5777c45019673125ad240f83094d4252d829516fac8601ed01979ec1ec1a251 175 !n = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551 176 !o = W.sub_mod a b n 177 !e = 0x44acf6b7e36c1342c2c5897204fe09504e1e2efb1a900377dbc4e7a6a133ec56 178 H.assertBool mempty (W.eq_vartime o e) 179 180 instance Q.Arbitrary W.Wider where 181 arbitrary = fmap W.to_vartime Q.arbitrary 182 183 odd_correct :: W.Wider -> Bool 184 odd_correct w = C.decide (W.odd w) == I.integerTestBit (W.from_vartime w) 0 185 186 lt_vartime_correct :: W.Wider -> W.Wider -> Bool 187 lt_vartime_correct a b = 188 W.lt_vartime a b == (W.from_vartime a < W.from_vartime b) 189 190 gt_vartime_correct :: W.Wider -> W.Wider -> Bool 191 gt_vartime_correct a b = 192 W.gt_vartime a b == (W.from_vartime a > W.from_vartime b) 193 194 tests :: TestTree 195 tests = testGroup "wider tests" [ 196 H.testCase "overflowing add, no carry" overflowing_add_no_carry 197 , H.testCase "overflowing add, carry" overflowing_add_with_carry 198 , H.testCase "wrapping add, no carry" wrapping_add_no_carry 199 , H.testCase "wrapping add, carry" wrapping_add_with_carry 200 , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow 201 , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow 202 , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow 203 , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow 204 , H.testCase "eq" eq 205 , H.testCase "gt" gt 206 , H.testCase "lt" lt 207 , H.testCase "gt_vartime" gt_vartime 208 , H.testCase "lt_vartime" lt_vartime 209 , H.testCase "cmp" cmp 210 , H.testCase "sqr" sqr 211 , H.testCase "mul" mul 212 , H.testCase "sub_mod" sub_mod 213 , Q.testProperty "odd w ~ odd (from w)" $ Q.withMaxSuccess 500 odd_correct 214 , Q.testProperty "lt_vartime a b ~ from a < from b" $ 215 Q.withMaxSuccess 500 lt_vartime_correct 216 , Q.testProperty "gt_vartime a b ~ from a > from b" $ 217 Q.withMaxSuccess 500 gt_vartime_correct 218 ] 219