{- |
A bit vector that represents a record in a bit-packed way.
-}
module Data.FlagSet (
   T(Cons, decons),
   fromMaskedValue, match,
   Enum(fromEnum),
   compose, decompose,
   Mask(Mask, unmask), maskValue,
   Value(Value, unvalue),
   MaskedValue(MaskedValue),
   get, put, accessor,
   ) where

import Data.Bits (Bits, (.&.), (.|.), )

import Data.Monoid (Monoid(mempty, mappend, mconcat), )
import Data.Semigroup (Semigroup((<>)), )

import qualified Foreign.Storable.Newtype as Store
import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )

import qualified Data.Accessor.Basic as Acc

import Data.EnumBitSet.Utility (empty, (.-.), )

import qualified Prelude as P
import Prelude hiding (Enum, fromEnum, toEnum, null, flip, )


{- |
The basic bit vector data type.
It does not provide a lot of functionality,
since that could not be done in a safe way.

The type @a@ identifies the maintained flags.
It may be an empty type
but it may also be an enumeration
of record fields with concrete values.
In the latter case you are encouraged to define an 'Enum' instance
for this enumeration.
Be aware that it is different from 'P.Enum' of Prelude.
-}
newtype T word a = Cons {T word a -> word
decons :: word}
   deriving (T word a -> T word a -> Bool
(T word a -> T word a -> Bool)
-> (T word a -> T word a -> Bool) -> Eq (T word a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall word a. Eq word => T word a -> T word a -> Bool
/= :: T word a -> T word a -> Bool
$c/= :: forall word a. Eq word => T word a -> T word a -> Bool
== :: T word a -> T word a -> Bool
$c== :: forall word a. Eq word => T word a -> T word a -> Bool
Eq)

instance (Storable w) => Storable (T w a) where
   sizeOf :: T w a -> Int
sizeOf = (T w a -> w) -> T w a -> Int
forall core wrapper.
Storable core =>
(wrapper -> core) -> wrapper -> Int
Store.sizeOf T w a -> w
forall word a. T word a -> word
decons
   alignment :: T w a -> Int
alignment = (T w a -> w) -> T w a -> Int
forall core wrapper.
Storable core =>
(wrapper -> core) -> wrapper -> Int
Store.alignment T w a -> w
forall word a. T word a -> word
decons
   peek :: Ptr (T w a) -> IO (T w a)
peek = (w -> T w a) -> Ptr (T w a) -> IO (T w a)
forall core wrapper.
Storable core =>
(core -> wrapper) -> Ptr wrapper -> IO wrapper
Store.peek w -> T w a
forall word a. word -> T word a
Cons
   poke :: Ptr (T w a) -> T w a -> IO ()
poke = (T w a -> w) -> Ptr (T w a) -> T w a -> IO ()
forall core wrapper.
Storable core =>
(wrapper -> core) -> Ptr wrapper -> wrapper -> IO ()
Store.poke T w a -> w
forall word a. T word a -> word
decons


{- |
@Mask w a b@ describes a field of a @T w a@ that has type @Value w b@.
On the machine level a 'Mask' value is a vector of bits,
where set bits represent the bits belonging to one record field.
There must be only one mask value for every pair of types @(a,b)@.
-}
newtype Mask w a b = Mask {Mask w a b -> w
unmask :: w}
   deriving (Mask w a b -> Mask w a b -> Bool
(Mask w a b -> Mask w a b -> Bool)
-> (Mask w a b -> Mask w a b -> Bool) -> Eq (Mask w a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall w a b. Eq w => Mask w a b -> Mask w a b -> Bool
/= :: Mask w a b -> Mask w a b -> Bool
$c/= :: forall w a b. Eq w => Mask w a b -> Mask w a b -> Bool
== :: Mask w a b -> Mask w a b -> Bool
$c== :: forall w a b. Eq w => Mask w a b -> Mask w a b -> Bool
Eq, Int -> Mask w a b -> ShowS
[Mask w a b] -> ShowS
Mask w a b -> String
(Int -> Mask w a b -> ShowS)
-> (Mask w a b -> String)
-> ([Mask w a b] -> ShowS)
-> Show (Mask w a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall w a b. Show w => Int -> Mask w a b -> ShowS
forall w a b. Show w => [Mask w a b] -> ShowS
forall w a b. Show w => Mask w a b -> String
showList :: [Mask w a b] -> ShowS
$cshowList :: forall w a b. Show w => [Mask w a b] -> ShowS
show :: Mask w a b -> String
$cshow :: forall w a b. Show w => Mask w a b -> String
showsPrec :: Int -> Mask w a b -> ShowS
$cshowsPrec :: forall w a b. Show w => Int -> Mask w a b -> ShowS
Show)

{- |
The type parameter @w@ is the type of the underlying bit vector.
The type parameter @b@ is a phantom type,
that is specific for a certain range of bits.
-}
newtype Value w b = Value {Value w b -> w
unvalue :: w}
   deriving (Value w b -> Value w b -> Bool
(Value w b -> Value w b -> Bool)
-> (Value w b -> Value w b -> Bool) -> Eq (Value w b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall w b. Eq w => Value w b -> Value w b -> Bool
/= :: Value w b -> Value w b -> Bool
$c/= :: forall w b. Eq w => Value w b -> Value w b -> Bool
== :: Value w b -> Value w b -> Bool
$c== :: forall w b. Eq w => Value w b -> Value w b -> Bool
Eq, Int -> Value w b -> ShowS
[Value w b] -> ShowS
Value w b -> String
(Int -> Value w b -> ShowS)
-> (Value w b -> String)
-> ([Value w b] -> ShowS)
-> Show (Value w b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall w b. Show w => Int -> Value w b -> ShowS
forall w b. Show w => [Value w b] -> ShowS
forall w b. Show w => Value w b -> String
showList :: [Value w b] -> ShowS
$cshowList :: forall w b. Show w => [Value w b] -> ShowS
show :: Value w b -> String
$cshow :: forall w b. Show w => Value w b -> String
showsPrec :: Int -> Value w b -> ShowS
$cshowsPrec :: forall w b. Show w => Int -> Value w b -> ShowS
Show)


get :: (Enum a, Bits w) => Mask w a b -> T w a -> Value w b
get :: Mask w a b -> T w a -> Value w b
get (Mask w
m) (Cons w
fs) = w -> Value w b
forall w b. w -> Value w b
Value (w
m w -> w -> w
forall a. Bits a => a -> a -> a
.&. w
fs)

{- |
All bits in Value must be contained in the mask.
This condition is not checked by 'put'.

According to names in "Data.Accessor" it should be called @set@,
but in "Data.Bits" and thus "Data.EnumSet"
this is already used in the pair @set@/@clear@.
@put@/@get@ resembles the pair in "Control.Monad.State" in the @mtl@ package.
-}
put :: (Enum a, Bits w) => Mask w a b -> Value w b -> T w a -> T w a
put :: Mask w a b -> Value w b -> T w a -> T w a
put (Mask w
m) (Value w
v) (Cons w
fs) =
   w -> T w a
forall word a. word -> T word a
Cons (w -> T w a) -> w -> T w a
forall a b. (a -> b) -> a -> b
$ (w
fs w -> w -> w
forall a. Bits a => a -> a -> a
.-. w
m) w -> w -> w
forall a. Bits a => a -> a -> a
.|. w
v

accessor :: (Enum a, Bits w) => Mask w a b -> Acc.T (T w a) (Value w b)
accessor :: Mask w a b -> T (T w a) (Value w b)
accessor Mask w a b
m = (Value w b -> T w a -> T w a)
-> (T w a -> Value w b) -> T (T w a) (Value w b)
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Acc.fromSetGet (Mask w a b -> Value w b -> T w a -> T w a
forall a w b.
(Enum a, Bits w) =>
Mask w a b -> Value w b -> T w a -> T w a
put Mask w a b
m) (Mask w a b -> T w a -> Value w b
forall a w b. (Enum a, Bits w) => Mask w a b -> T w a -> Value w b
get Mask w a b
m)



{- |
Combines a mask with a value, that matches this mask.
In @MaskedValue mask value@, @value@ must be a subset of @mask@.
-}
data MaskedValue w a = MaskedValue w w
   deriving (MaskedValue w a -> MaskedValue w a -> Bool
(MaskedValue w a -> MaskedValue w a -> Bool)
-> (MaskedValue w a -> MaskedValue w a -> Bool)
-> Eq (MaskedValue w a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall w a. Eq w => MaskedValue w a -> MaskedValue w a -> Bool
/= :: MaskedValue w a -> MaskedValue w a -> Bool
$c/= :: forall w a. Eq w => MaskedValue w a -> MaskedValue w a -> Bool
== :: MaskedValue w a -> MaskedValue w a -> Bool
$c== :: forall w a. Eq w => MaskedValue w a -> MaskedValue w a -> Bool
Eq, Int -> MaskedValue w a -> ShowS
[MaskedValue w a] -> ShowS
MaskedValue w a -> String
(Int -> MaskedValue w a -> ShowS)
-> (MaskedValue w a -> String)
-> ([MaskedValue w a] -> ShowS)
-> Show (MaskedValue w a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall w a. Show w => Int -> MaskedValue w a -> ShowS
forall w a. Show w => [MaskedValue w a] -> ShowS
forall w a. Show w => MaskedValue w a -> String
showList :: [MaskedValue w a] -> ShowS
$cshowList :: forall w a. Show w => [MaskedValue w a] -> ShowS
show :: MaskedValue w a -> String
$cshow :: forall w a. Show w => MaskedValue w a -> String
showsPrec :: Int -> MaskedValue w a -> ShowS
$cshowsPrec :: forall w a. Show w => Int -> MaskedValue w a -> ShowS
Show)


fromMaskedValue :: MaskedValue w a -> T w a
fromMaskedValue :: MaskedValue w a -> T w a
fromMaskedValue (MaskedValue w
_m w
v) = w -> T w a
forall word a. word -> T word a
Cons w
v

match :: (Bits w) => T w a -> MaskedValue w a -> Bool
match :: T w a -> MaskedValue w a -> Bool
match (Cons w
fs) (MaskedValue w
m w
v) =
   w
m w -> w -> w
forall a. Bits a => a -> a -> a
.&. w
fs  w -> w -> Bool
forall a. Eq a => a -> a -> Bool
==  w
v


maskValue :: Mask w a b -> Value w b -> MaskedValue w a
maskValue :: Mask w a b -> Value w b -> MaskedValue w a
maskValue (Mask w
m) (Value w
v) = w -> w -> MaskedValue w a
forall w a. w -> w -> MaskedValue w a
MaskedValue w
m w
v


instance (Bits w) => Semigroup (MaskedValue w a) where
   MaskedValue w
mx w
vx <> :: MaskedValue w a -> MaskedValue w a -> MaskedValue w a
<> MaskedValue w
my w
vy =
      w -> w -> MaskedValue w a
forall w a. w -> w -> MaskedValue w a
MaskedValue (w
mx w -> w -> w
forall a. Bits a => a -> a -> a
.|. w
my) (w
vx w -> w -> w
forall a. Bits a => a -> a -> a
.-. w
my  w -> w -> w
forall a. Bits a => a -> a -> a
.|.  w
vy)

{- |
@mappend a b@ means that values stored in @b@ overwrite corresponding values in @a@.
-}
instance (Bits w) => Monoid (MaskedValue w a) where
   mempty :: MaskedValue w a
mempty = w -> w -> MaskedValue w a
forall w a. w -> w -> MaskedValue w a
MaskedValue w
forall w. Bits w => w
empty w
forall w. Bits w => w
empty
   mappend :: MaskedValue w a -> MaskedValue w a -> MaskedValue w a
mappend = MaskedValue w a -> MaskedValue w a -> MaskedValue w a
forall a. Semigroup a => a -> a -> a
(<>)


class Enum a where
   {- |
   'P.fromEnum' should return an integer
   that represents the position of the @a@ value
   in the list of all enumeration items.
   In contrast to that,
   'fromEnum' must return the according bit pattern.
   -}
   fromEnum :: (Bits w) => a -> MaskedValue w a

{- |
Decompose a flag set into flags.
The flags are generated using the 'Bounded' and 'Enum' instance.
We do not recommend to use the result list for further processing,
since testing of flags is much faster using 'match'.
However you may find it useful to 'show' the list.
-}
decompose :: (Bounded a, Enum a, P.Enum a, Bits w) => T w a -> [a]
decompose :: T w a -> [a]
decompose T w a
x =
   (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (T w a -> MaskedValue w a -> Bool
forall w a. Bits w => T w a -> MaskedValue w a -> Bool
match T w a
x (MaskedValue w a -> Bool) -> (a -> MaskedValue w a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MaskedValue w a
forall a w. (Enum a, Bits w) => a -> MaskedValue w a
fromEnum) [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]

{- |
Compose a flag set from a list of flags.
However you may prefer to assemble flags
using 'mconcat' or 'mappend' on 'MaskedValue's.
-}
compose :: (Enum a, P.Enum a, Bits w) => [a] -> T w a
compose :: [a] -> T w a
compose [a]
xs =
   MaskedValue w a -> T w a
forall w a. MaskedValue w a -> T w a
fromMaskedValue (MaskedValue w a -> T w a) -> MaskedValue w a -> T w a
forall a b. (a -> b) -> a -> b
$ [MaskedValue w a] -> MaskedValue w a
forall a. Monoid a => [a] -> a
mconcat ([MaskedValue w a] -> MaskedValue w a)
-> [MaskedValue w a] -> MaskedValue w a
forall a b. (a -> b) -> a -> b
$ (a -> MaskedValue w a) -> [a] -> [MaskedValue w a]
forall a b. (a -> b) -> [a] -> [b]
map a -> MaskedValue w a
forall a w. (Enum a, Bits w) => a -> MaskedValue w a
fromEnum [a]
xs