Commit 349b3755 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Add monoid wrappers for .&. and .|.

parent a17eec00
......@@ -34,6 +34,7 @@ library
, Data.List.Utils
, Data.Text.Prettyprint
, Data.SumBag
, Data.Bits.Monoid
, Copar.RefinementInterface
, Copar.Functors
, Copar.FunctorDescription
......@@ -137,6 +138,7 @@ test-suite spec
, Data.List.UtilsSpec
, Data.Float.UtilsSpec
, Data.SumBagSpec
, Data.Bits.MonoidSpec
, Copar.Functors.PowersetSpec
, Copar.Functors.GroupValuedSpec
, Copar.Functors.BagSpec
......@@ -168,6 +170,7 @@ test-suite spec
build-depends: base >= 4.11
, hspec
, QuickCheck
, quickcheck-classes >= 0.6 && <0.7
, vector
, vector-algorithms
, bytestring
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Newtype wrappers around 'Bits' implementors to provide monoid instances
-- with '.&.' and '.|.'.
module Data.Bits.Monoid (BitAnd(..), BitOr(..)) where
import Data.Bits
import Data.Semigroup ( Semigroup(..)
, stimesMonoid
)
import Control.DeepSeq
-- | Wrapper that provides a 'Semigroup'/'Monoid' instances for the wrapped type
-- using its 'Bits' instance:
--
-- * 'mempty' is all bits set
-- * '<>' is '.&.'
newtype BitAnd a = BitAnd { getBitAnd :: a }
deriving (Eq, Ord, Show, Read, Num, Real, Enum, Integral, Bits, NFData)
instance (Bits a) => Semigroup (BitAnd a) where
(<>) = (.&.)
stimes = stimesMonoid
instance (Bits a) => Monoid (BitAnd a) where
mempty = (complement zeroBits)
-- | Wrapper that provides a 'Semigroup'/'Monoid' instances for the wrapped type
-- using its 'Bits' instance:
--
-- * 'mempty' is all bits cleared
-- * '<>' is '.|.'
newtype BitOr a = BitOr { getBitOr :: a }
deriving (Eq, Ord, Show, Read, Num, Real, Enum, Integral, Bits, NFData)
instance (Bits a) => Semigroup (BitOr a) where
(<>) = (.|.)
stimes = stimesMonoid
instance (Bits a) => Monoid (BitOr a) where
mempty = zeroBits
......@@ -5,6 +5,7 @@ packages:
extra-deps:
- prettyprinter-convert-ansi-wl-pprint-1.1
- quickcheck-classes-0.6.1.0
# Override default flag values for local packages and extra-deps
flags:
......@@ -12,6 +13,10 @@ flags:
parsec: false
pretty: false
generic: false
quickcheck-classes:
aeson: false
semigroupoids: false
semirings: false
# Control whether we use the GHC we find on the path
system-ghc: true
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Bits.MonoidSpec (spec) where
import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Classes
import Data.Foldable
import Data.Proxy
import Data.Bits.Monoid
spec :: Spec
spec = do
andSpec
orSpec
deriving instance (Arbitrary a) => Arbitrary (BitAnd a)
deriving instance (Arbitrary a) => Arbitrary (BitOr a)
andSpec :: Spec
andSpec = describe "and" $ do
it "works for a simple example" $
let res = 0xCAACBACE :: BitAnd Word
in 0xdeadbeef <> 0xcafeface `shouldBe` res
lawsToSpec (semigroupLaws (Proxy @(BitAnd Word)))
lawsToSpec (commutativeSemigroupLaws (Proxy @(BitAnd Word)))
lawsToSpec (monoidLaws (Proxy @(BitAnd Word)))
lawsToSpec (commutativeMonoidLaws (Proxy @(BitAnd Word)))
orSpec :: Spec
orSpec = describe "or" $ do
it "works for a simple example" $
let res = 0xDEFFFEEF :: BitOr Word
in 0xdeadbeef <> 0xcafeface `shouldBe` res
lawsToSpec (semigroupLaws (Proxy @(BitOr Word)))
lawsToSpec (commutativeSemigroupLaws (Proxy @(BitOr Word)))
lawsToSpec (monoidLaws (Proxy @(BitOr Word)))
lawsToSpec (commutativeMonoidLaws (Proxy @(BitOr Word)))
lawsToSpec :: Laws -> Spec
lawsToSpec laws = context ("laws for " ++ lawsTypeclass laws) $
traverse_ lawToSpec (lawsProperties laws)
where lawToSpec (name, prop) = specify name (property prop)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment