Wider.hs (5508B)
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 cmp :: H.Assertion 106 cmp = do 107 let !a = 0 108 !b = 1 109 !c = 2 ^ (256 :: Word) - 1 110 H.assertEqual mempty (W.cmp_vartime a b) LT 111 H.assertEqual mempty (W.cmp_vartime a c) LT 112 H.assertEqual mempty (W.cmp_vartime b c) LT 113 114 H.assertEqual mempty (W.cmp_vartime a a) EQ 115 H.assertEqual mempty (W.cmp_vartime b b) EQ 116 H.assertEqual mempty (W.cmp_vartime c c) EQ 117 118 H.assertEqual mempty (W.cmp_vartime b a) GT 119 H.assertEqual mempty (W.cmp_vartime c a) GT 120 H.assertEqual mempty (W.cmp_vartime c b) GT 121 122 sqr :: H.Assertion 123 sqr = do 124 let !n = 2 ^ (256 :: Word) - 1 125 !(l, h ) = W.sqr n 126 H.assertBool mempty (W.eq_vartime l 1) 127 H.assertBool mempty (W.eq_vartime h (n - 1)) 128 129 mul :: H.Assertion 130 mul = do 131 let !n = 2 ^ (256 :: Word) - 1 132 H.assertBool mempty (W.eq_vartime (W.mul 0 n) 0) 133 H.assertBool mempty (W.eq_vartime (W.mul n 0) 0) 134 H.assertBool mempty (W.eq_vartime (W.mul n n) 1) 135 H.assertBool mempty (W.eq_vartime (W.mul 1 n) n) 136 137 sub_mod :: H.Assertion 138 sub_mod = do 139 let !a = 0x1a2472fde50286541d97ca6a3592dd75beb9c9646e40c511b82496cfc3926956 140 !b = 0xd5777c45019673125ad240f83094d4252d829516fac8601ed01979ec1ec1a251 141 !n = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551 142 !o = W.sub_mod a b n 143 !e = 0x44acf6b7e36c1342c2c5897204fe09504e1e2efb1a900377dbc4e7a6a133ec56 144 H.assertBool mempty (W.eq_vartime o e) 145 146 instance Q.Arbitrary W.Wider where 147 arbitrary = fmap W.to_vartime Q.arbitrary 148 149 odd_correct :: W.Wider -> Bool 150 odd_correct w = C.decide (W.odd w) == I.integerTestBit (W.from_vartime w) 0 151 152 tests :: TestTree 153 tests = testGroup "wider tests" [ 154 H.testCase "overflowing add, no carry" overflowing_add_no_carry 155 , H.testCase "overflowing add, carry" overflowing_add_with_carry 156 , H.testCase "wrapping add, no carry" wrapping_add_no_carry 157 , H.testCase "wrapping add, carry" wrapping_add_with_carry 158 , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow 159 , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow 160 , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow 161 , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow 162 , H.testCase "eq" eq 163 , H.testCase "gt" gt 164 , H.testCase "lt" lt 165 , H.testCase "cmp" cmp 166 , H.testCase "sqr" sqr 167 , H.testCase "mul" mul 168 , H.testCase "sub_mod" sub_mod 169 , Q.testProperty "odd w ~ odd (from w)" $ Q.withMaxSuccess 500 odd_correct 170 ] 171