Wide.hs (1739B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE MagicHash #-} 3 {-# LANGUAGE UnboxedTuples #-} 4 5 module Wide ( 6 tests 7 ) where 8 9 import qualified Data.Choice as C 10 import qualified Data.Word.Wide as W 11 import Test.Tasty 12 import qualified Test.Tasty.HUnit as H 13 14 overflowing_add_no_carry :: H.Assertion 15 overflowing_add_no_carry = do 16 let !(r, c) = W.add_o 1 0 17 H.assertBool mempty (W.eq_vartime r 1) 18 H.assertBool mempty (c == 0) 19 20 overflowing_add_with_carry :: H.Assertion 21 overflowing_add_with_carry = do 22 let !(r, c) = W.add_o (2 ^ (128 :: Word) - 1) 1 23 H.assertBool mempty (W.eq_vartime r 0) 24 H.assertBool mempty (c == 1) 25 26 wrapping_add_no_carry :: H.Assertion 27 wrapping_add_no_carry = do 28 let !r = W.add 0 1 29 H.assertBool mempty (W.eq_vartime r 1) 30 31 wrapping_add_with_carry :: H.Assertion 32 wrapping_add_with_carry = do 33 let !r = W.add (2 ^ (128 :: Word) - 1) 1 34 H.assertBool mempty (W.eq_vartime r 0) 35 36 eq :: H.Assertion 37 eq = do 38 let !a = 0 :: W.Wide 39 !b = 2 ^ (128 :: Word) - 1 40 H.assertBool mempty (C.decide (W.eq a a)) 41 H.assertBool mempty (not (C.decide (W.eq a b))) 42 H.assertBool mempty (C.decide (W.eq b b)) 43 -- eq must yield a full-word mask, not a bare bit; negating or 44 -- selecting on it is otherwise wrong 45 H.assertBool mempty (not (C.decide (C.not (W.eq a a)))) 46 H.assertBool mempty (C.decide (C.not (W.eq a b))) 47 H.assertBool mempty (W.eq_vartime (W.select a b (W.eq a a)) b) 48 49 tests :: TestTree 50 tests = testGroup "wide tests" [ 51 H.testCase "overflowing add, no carry" overflowing_add_no_carry 52 , H.testCase "overflowing add, carry" overflowing_add_with_carry 53 , H.testCase "wrapping add, no carry" wrapping_add_no_carry 54 , H.testCase "wrapping add, carry" wrapping_add_with_carry 55 , H.testCase "eq" eq 56 ] 57