diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2014 Mikhail Vorozhtsov +Copyright (c) 2011-2018 Mikhail Vorozhtsov All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/data-dword.cabal b/data-dword.cabal --- a/data-dword.cabal +++ b/data-dword.cabal @@ -1,5 +1,5 @@ Name: data-dword -Version: 0.3.1.1 +Version: 0.3.1.2 Category: Data Stability: experimental Synopsis: Stick two binary words together to get a bigger one @@ -13,7 +13,7 @@ Author: Mikhail Vorozhtsov Maintainer: Mikhail Vorozhtsov -Copyright: 2011-2014 Mikhail Vorozhtsov +Copyright: 2011-2018 Mikhail Vorozhtsov License: BSD3 License-File: LICENSE diff --git a/src/Data/DoubleWord/TH.hs b/src/Data/DoubleWord/TH.hs --- a/src/Data/DoubleWord/TH.hs +++ b/src/Data/DoubleWord/TH.hs @@ -232,17 +232,15 @@ appV 'enumFromThenTo [ VarE x , VarE y - , CondE (appVN '(>=) [x, y]) (VarE 'maxBound) (VarE 'minBound) + , CondE (appVN '(>=) [y, x]) (VarE 'maxBound) (VarE 'minBound) ] , inlinable 'enumFromThen {- enumFromTo x y = case y `compare` x of - LT → x : down y x + LT → [] EQ → [x] GT → x : up y x - where down to c = next : if next == to then [] else down to next - where next = c - 1 - up to c = next : if next == to then [] else up to next + where up to c = next : if next == to then [] else up to next where next = c + 1 -} , FunD 'enumFromTo $ return $ @@ -250,30 +248,11 @@ [VarP x, VarP y] (NormalB $ CaseE (appVN 'compare [y, x]) - [ Match - (ConP 'LT []) - (NormalB $ appC '(:) [VarE x, appVN down [y, x]]) - [] - , Match - (ConP 'EQ []) - (NormalB $ appC '(:) [VarE x, ConE '[]]) - [] - , Match - (ConP 'GT []) - (NormalB $ appC '(:) [VarE x, appVN up [y, x]]) - [] + [ match (ConP 'LT []) (ConE '[]) + , match (ConP 'EQ []) (singE $ VarE x) + , match (ConP 'GT []) $ appC '(:) [VarE x, appVN up [y, x]] ]) - [ FunD down $ return $ - Clause [VarP to, VarP c] - (NormalB $ - appC '(:) - [ VarE next - , CondE (appVN '(==) [next, to]) - (ConE '[]) (appVN down [to, next]) - ]) - [ValD (VarP next) - (NormalB $ appVN '(-) [c, 'lsb]) []] - , FunD up $ return $ + [ FunD up $ return $ Clause [VarP to, VarP c] (NormalB $ appC '(:) @@ -281,56 +260,66 @@ , CondE (appVN '(==) [next, to]) (ConE '[]) (appVN up [to, next]) ]) - [ValD (VarP next) - (NormalB $ appVN '(+) [c, 'lsb]) []] + [val next $ appVN '(+) [c, 'lsb]] ] {- enumFromThenTo x y z = case y `compare` x of - LT → if z > x then [] else down (x - y) z x - EQ → repeat x - GT → if z < x then [] else up (y - x) z x - where down s to c = c : if next < to then [] else down s to next - where next = c - s - up s to c = c : if next > to then [] else up s to next - where next = c + s + LT → if z > y then (if z > x then [] else [x]) + else x : down step (z + step) y + where step = x - y + to = z + step + down c | c < to = [c] + | otherwise = c : down (c - step) + EQ → if z < x then [] else repeat x + GT → if z < y then (if z < x then [] else [x]) + else x : up step (z - step) y + where step = y - x + to = z - step + up c | c > to = [c] + | otherwise = c : up (c + step) -} , FunD 'enumFromThenTo $ return $ Clause [VarP x, VarP y, VarP z] (NormalB $ CaseE (appVN 'compare [y, x]) - [ Match + [ match' (ConP 'LT []) - (NormalB $ - CondE (appVN '(>) [z, x]) - (ConE '[]) - (appV down [appVN '(-) [x, y], VarE z, VarE x])) - [] - , Match (ConP 'EQ []) (NormalB $ appVN 'repeat [x]) [] - , Match + (CondE (appVN '(>) [z, y]) + (CondE (appVN '(>) [z, x]) + (ConE '[]) (singE $ VarE x)) + (appC '(:) [VarE x, appVN down [y]])) + [ val step $ appVN '(-) [x, y] + , val to $ appVN '(+) [z, step] + , fun1 down c $ + CondE (appVN '(<) [c, to]) + (singE $ VarE c) + (appC '(:) + [ VarE c + , appV down [appVN '(-) [c, step]] + ]) + ] + , match + (ConP 'EQ []) + (CondE (appVN '(<) [z, x]) + (ConE '[]) (appVN 'repeat [x])) + , match' (ConP 'GT []) - (NormalB $ - CondE (appVN '(<) [z, x]) (ConE '[]) - (appV up [appVN '(-) [y, x], VarE z, VarE x])) - [] + (CondE (appVN '(<) [z, y]) + (CondE (appVN '(<) [z, x]) + (ConE '[]) (singE $ VarE x)) + (appC '(:) [VarE x, appVN up [y]])) + [ val step $ appVN '(-) [y, x] + , val to $ appVN '(-) [z, step] + , fun1 up c $ + CondE (appVN '(>) [c, to]) + (singE $ VarE c) + (appC '(:) + [ VarE c + , appV up [appVN '(+) [c, step]] + ]) + ] ]) - [ FunD down $ return $ - Clause [VarP step, VarP to, VarP c] - (NormalB $ - appC '(:) - [ VarE c - , CondE (appVN '(<) [next, to]) - (ConE '[]) (appVN down [step, to, next]) - ]) - [ValD (VarP next) (NormalB $ appVN '(-) [c, step]) []] - , FunD up $ return $ - Clause [VarP step, VarP to, VarP c] - (NormalB $ - appC '(:) - [ VarE c - , CondE (appVN '(==) [next, to]) - (ConE '[]) (appVN up [step, to, next]) - ]) - [ValD (VarP next) (NormalB $ appVN '(+) [c, step]) []]] + [] ] , inst ''Num [tp] {- @@ -1401,6 +1390,7 @@ #endif [] (foldl AppT (ConT cls) (ConT <$> params)) fun n e = FunD n [Clause [] (NormalB e) []] + fun1 n a e = FunD n [Clause [VarP a] (NormalB e) []] fun_ n e = FunD n [Clause [WildP] (NormalB e) []] funX' n e ds = FunD n [Clause [VarP x] (NormalB e) ds] funX n e = funX' n e [] @@ -1456,6 +1446,7 @@ hiSizeE = appV 'bitSize [SigE (VarE 'undefined) hiT] sizeE = appV 'bitSize [SigE (VarE 'undefined) tpT] #endif + singE e = appC '(:) [e, ConE '[]] mkRules = do let idRule = RuleP ("fromIntegral/" ++ show tp ++ "->" ++ show tp) [] (VarE 'fromIntegral) diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -60,7 +60,10 @@ , testProperty "maxBound" $ prop_maxBound t ] , testGroup "Enum" [ testProperty "succ" $ prop_succ t - , testProperty "pred" $ prop_pred t ] + , testProperty "pred" $ prop_pred t + , testProperty "enumFromTo" $ prop_enumFromTo t + , testProperty "enumFromThen" $ prop_enumFromThen t + , testProperty "enumFromThenTo" $ prop_enumFromThenTo t ] , testGroup "Num" [ testProperty "negate" $ prop_negate t , testProperty "abs" $ prop_abs t @@ -131,12 +134,18 @@ withBinary' ∷ Iso α τ ⇒ τ → (τ → τ → β) → α → α → β withBinary' _ f x y = f (fromArbitrary x) (fromArbitrary y) +withTernary' ∷ Iso α τ ⇒ τ → (τ → τ → τ → β) → α → α → α → β +withTernary' _ f x y z = + f (fromArbitrary x) (fromArbitrary y) (fromArbitrary z) + propUnary f g t w = f w == withUnary t g w propUnary' f g t w = f w == withUnary' t g w propBinary f g t w1 w2 = f w1 w2 == withBinary t g w1 w2 propBinary' f g t w1 w2 = f w1 w2 == withBinary' t g w1 w2 +propTernary' f g t w1 w2 w3 = f w1 w2 w3 == withTernary' t g w1 w2 w3 + prop_conv t w = toArbitrary (toType t w) == w prop_eq = propBinary' (==) (==) @@ -148,6 +157,15 @@ prop_succ t w = (w /= maxBound) ==> (succ w == withUnary t succ w) prop_pred t w = (w /= minBound) ==> (pred w == withUnary t pred w) +prop_enumFromTo = + propBinary' ((take 8 .) . enumFromTo) + (((fmap toArbitrary . take 8) .) . enumFromTo) +prop_enumFromThen = + propBinary' ((take 8 .) . enumFromThen) + (((fmap toArbitrary . take 8) .) . enumFromThen) +prop_enumFromThenTo = + propTernary' (((take 8 .) .) . enumFromThenTo) + ((((fmap toArbitrary . take 8) .) .) . enumFromThenTo) prop_unwrappedAdd ∷ (Iso α τ, Iso (UnsignedWord α) (UnsignedWord τ), BinaryWord α, BinaryWord τ)