{- |
Similar to Data.Edison.Coll.EnumSet
but it allows to choose the underlying type for bit storage.
This is really a low-level module for type-safe foreign function interfaces.

The integer representation of the enumeration type
is the bit position of the flag within the bitvector.
-}
module Data.EnumBitSet (
   T(Cons, decons),
   fromEnum,
   fromEnums,
   toEnums,
   intToEnums,
   mostSignificantPosition,
   singletonByPosition,
   null,
   empty,
   singleton,
   disjoint,
   subset,
   (.&.),
   (.-.),
   (.|.),
   xor,
   unions,
   get,
   put,
   accessor,
   set,
   clear,
   flip,
   fromBool,
   ) where

import qualified Data.EnumBitSet.Utility as U
import qualified Data.Bits as B
import Data.Bits (Bits, )

import Data.Monoid (Monoid(mempty, mappend), )
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 qualified Prelude as P
import Prelude hiding (fromEnum, toEnum, null, flip, )


newtype T word index = Cons {T word index -> word
decons :: word}
   deriving (T word index -> T word index -> Bool
(T word index -> T word index -> Bool)
-> (T word index -> T word index -> Bool) -> Eq (T word index)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall word index. Eq word => T word index -> T word index -> Bool
/= :: T word index -> T word index -> Bool
$c/= :: forall word index. Eq word => T word index -> T word index -> Bool
== :: T word index -> T word index -> Bool
$c== :: forall word index. Eq word => T word index -> T word index -> Bool
Eq)

instance (Enum a, 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 index. T word index -> 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 index. T word index -> 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 index. word -> T word index
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 index. T word index -> word
decons


instance (Enum a, Bits w) => Semigroup (T w a) where
   <> :: T w a -> T w a -> T w a
(<>) = T w a -> T w a -> T w a
forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
(.|.)

{- |
Since this data type is intended for constructing flags,
we choose the set union as 'mappend'.
For intersection we would also not have a canonical identity element.
-}
instance (Enum a, Bits w) => Monoid (T w a) where
   mempty :: T w a
mempty = T w a
forall a w. (Enum a, Bits w) => T w a
empty
   mappend :: T w a -> T w a -> T w a
mappend = T w a -> T w a -> T w a
forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
(.|.)


fromEnum :: (Enum a, Bits w) => a -> T w a
fromEnum :: a -> T w a
fromEnum = w -> T w a
forall word index. word -> T word index
Cons (w -> T w a) -> (a -> w) -> a -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> w
forall a. Bits a => Int -> a
B.bit (Int -> w) -> (a -> Int) -> a -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
P.fromEnum

fromEnums :: (Enum a, Bits w) => [a] -> T w a
fromEnums :: [a] -> T w a
fromEnums = w -> T w a
forall word index. word -> T word index
Cons (w -> T w a) -> ([a] -> w) -> [a] -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> Int -> w) -> w -> [Int] -> w
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl w -> Int -> w
forall a. Bits a => a -> Int -> a
B.setBit w
forall w. Bits w => w
U.empty ([Int] -> w) -> ([a] -> [Int]) -> [a] -> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map a -> Int
forall a. Enum a => a -> Int
P.fromEnum

toEnums :: (Enum a, Bits w) => T w a -> [a]
toEnums :: T w a -> [a]
toEnums =
   ((a, w) -> a) -> [(a, w)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, w) -> a
forall a b. (a, b) -> a
fst ([(a, w)] -> [a]) -> (T w a -> [(a, w)]) -> T w a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, w) -> Bool) -> [(a, w)] -> [(a, w)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((w -> Int -> Bool) -> Int -> w -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
P.flip w -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
B.testBit Int
0 (w -> Bool) -> ((a, w) -> w) -> (a, w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> w
forall a b. (a, b) -> b
snd) ([(a, w)] -> [(a, w)]) -> (T w a -> [(a, w)]) -> T w a -> [(a, w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   [a] -> [w] -> [(a, w)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int -> a
forall a. Enum a => Int -> a
P.toEnum Int
0 ..] ([w] -> [(a, w)]) -> (T w a -> [w]) -> T w a -> [(a, w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (w -> Bool) -> [w] -> [w]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (w
forall w. Bits w => w
U.empty w -> w -> Bool
forall a. Eq a => a -> a -> Bool
/= ) ([w] -> [w]) -> (T w a -> [w]) -> T w a -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> w) -> w -> [w]
forall a. (a -> a) -> a -> [a]
iterate ((w -> Int -> w) -> Int -> w -> w
forall a b c. (a -> b -> c) -> b -> a -> c
P.flip w -> Int -> w
forall a. Bits a => a -> Int -> a
B.shiftR Int
1) (w -> [w]) -> (T w a -> w) -> T w a -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   T w a -> w
forall word index. T word index -> word
decons

intToEnums :: (Enum a, Integral w) => T w a -> [a]
intToEnums :: T w a -> [a]
intToEnums =
   ((a, w) -> a) -> [(a, w)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, w) -> a
forall a b. (a, b) -> a
fst ([(a, w)] -> [a]) -> (T w a -> [(a, w)]) -> T w a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, w) -> Bool) -> [(a, w)] -> [(a, w)]
forall a. (a -> Bool) -> [a] -> [a]
filter (w -> Bool
forall a. Integral a => a -> Bool
odd (w -> Bool) -> ((a, w) -> w) -> (a, w) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> w
forall a b. (a, b) -> b
snd) ([(a, w)] -> [(a, w)]) -> (T w a -> [(a, w)]) -> T w a -> [(a, w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   [a] -> [w] -> [(a, w)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int -> a
forall a. Enum a => Int -> a
P.toEnum Int
0 ..] ([w] -> [(a, w)]) -> (T w a -> [w]) -> T w a -> [(a, w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (w -> Bool) -> [w] -> [w]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (w
0w -> w -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([w] -> [w]) -> (T w a -> [w]) -> T w a -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> w) -> w -> [w]
forall a. (a -> a) -> a -> [a]
iterate ((w -> w -> w) -> w -> w -> w
forall a b c. (a -> b -> c) -> b -> a -> c
P.flip w -> w -> w
forall a. Integral a => a -> a -> a
div w
2) (w -> [w]) -> (T w a -> w) -> T w a -> [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   T w a -> w
forall word index. T word index -> word
decons


{- |
floor of binary logarithm -
Intended for getting the position of a single set bit.
This in turn is intended for implementing an 'Enum' instance
if you only know masks but no bit positions.
-}
{-# INLINE mostSignificantPosition #-}
mostSignificantPosition :: (Bits w, Storable w) => T w a -> Int
mostSignificantPosition :: T w a -> Int
mostSignificantPosition (Cons w
x) =
   (w, Int) -> Int
forall a b. (a, b) -> b
snd ((w, Int) -> Int) -> (w, Int) -> Int
forall a b. (a -> b) -> a -> b
$
   ((w, Int) -> Int -> (w, Int)) -> (w, Int) -> [Int] -> (w, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
      (\(w
x0,Int
pos) Int
testPos ->
         let x1 :: w
x1 = w -> Int -> w
forall a. Bits a => a -> Int -> a
B.shiftR w
x0 Int
testPos
         in  if w
x1 w -> w -> Bool
forall a. Eq a => a -> a -> Bool
== w
forall w. Bits w => w
U.empty
               then (w
x0, Int
pos)
               else (w
x1, Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
testPos))
      (w
x,Int
0) ([Int] -> (w, Int)) -> [Int] -> (w, Int)
forall a b. (a -> b) -> a -> b
$
   [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
   (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< w -> Int
forall a. Storable a => a -> Int
sizeOf w
x Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
   (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*) Int
1

{- |
set a bit -
Intended for implementing an 'Enum' instance
if you only know masks but no bit positions.
-}
{-# INLINE singletonByPosition #-}
singletonByPosition :: (Bits w) => Int -> T w a
singletonByPosition :: Int -> T w a
singletonByPosition = w -> T w a
forall word index. word -> T word index
Cons (w -> T w a) -> (Int -> w) -> Int -> T w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Int -> w
forall a. Bits a => a -> Int -> a
B.setBit w
forall w. Bits w => w
U.empty


null :: (Enum a, Bits w) => T w a -> Bool
null :: T w a -> Bool
null (Cons w
x)  =  w
xw -> w -> Bool
forall a. Eq a => a -> a -> Bool
==w
forall w. Bits w => w
U.empty

empty :: (Enum a, Bits w) => T w a
empty :: T w a
empty = w -> T w a
forall word index. word -> T word index
Cons w
forall w. Bits w => w
U.empty

disjoint :: (Enum a, Bits w) => T w a -> T w a -> Bool
disjoint :: T w a -> T w a -> Bool
disjoint T w a
x T w a
y = T w a -> Bool
forall a w. (Enum a, Bits w) => T w a -> Bool
null (T w a
x T w a -> T w a -> T w a
forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.&. T w a
y)

{- |
@subset a b@ is 'True' if @a@ is a subset of @b@.
-}
subset :: (Enum a, Bits w) => T w a -> T w a -> Bool
subset :: T w a -> T w a -> Bool
subset T w a
x T w a
y = T w a -> Bool
forall a w. (Enum a, Bits w) => T w a -> Bool
null (T w a
x T w a -> T w a -> T w a
forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.-. T w a
y)


{-# INLINE lift2 #-}
lift2 :: (w -> w -> w) -> (T w a -> T w a -> T w a)
lift2 :: (w -> w -> w) -> T w a -> T w a -> T w a
lift2 w -> w -> w
f (Cons w
x) (Cons w
y) = w -> T w a
forall word index. word -> T word index
Cons (w -> w -> w
f w
x w
y)

-- fixities like in Data.Bits
infixl 7 .&., .-.
infixl 5 .|.

(.&.), (.-.), (.|.), xor :: (Enum a, Bits w) => T w a -> T w a -> T w a
.&. :: T w a -> T w a -> T w a
(.&.) = (w -> w -> w) -> T w a -> T w a -> T w a
forall w a. (w -> w -> w) -> T w a -> T w a -> T w a
lift2 w -> w -> w
forall a. Bits a => a -> a -> a
(B..&.)
.|. :: T w a -> T w a -> T w a
(.|.) = (w -> w -> w) -> T w a -> T w a -> T w a
forall w a. (w -> w -> w) -> T w a -> T w a -> T w a
lift2 w -> w -> w
forall a. Bits a => a -> a -> a
(B..|.)
.-. :: T w a -> T w a -> T w a
(.-.) = (w -> w -> w) -> T w a -> T w a -> T w a
forall w a. (w -> w -> w) -> T w a -> T w a -> T w a
lift2 (\w
x w
y -> w
x w -> w -> w
forall a. Bits a => a -> a -> a
B..&. w -> w
forall a. Bits a => a -> a
B.complement w
y)
xor :: T w a -> T w a -> T w a
xor   = (w -> w -> w) -> T w a -> T w a -> T w a
forall w a. (w -> w -> w) -> T w a -> T w a -> T w a
lift2 w -> w -> w
forall a. Bits a => a -> a -> a
B.xor

unions :: (Enum a, Bits w) => [T w a] -> T w a
unions :: [T w a] -> T w a
unions = (T w a -> T w a -> T w a) -> T w a -> [T w a] -> T w a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl T w a -> T w a -> T w a
forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
(.|.) T w a
forall a w. (Enum a, Bits w) => T w a
empty


-- | could also be named @member@ like in @Set@ or @elem@ as in '[]'
get :: (Enum a, Bits w) => a -> T w a -> Bool
get :: a -> T w a -> Bool
get a
n = (w -> Int -> Bool) -> Int -> w -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
P.flip w -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
B.testBit (a -> Int
forall a. Enum a => a -> Int
P.fromEnum a
n) (w -> Bool) -> (T w a -> w) -> T w a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T w a -> w
forall word index. T word index -> word
decons

put :: (Enum a, Bits w) => a -> Bool -> T w a -> T w a
put :: a -> Bool -> T w a -> T w a
put a
n Bool
b T w a
s =
   a -> Bool -> T w a
forall a w. (Enum a, Bits w) => a -> Bool -> T w a
fromBool a
n Bool
b T w a -> T w a -> T w a
forall a w. (Enum a, Bits w) => T w a -> T w a -> T w a
.|. a -> T w a -> T w a
forall a w. (Enum a, Bits w) => a -> T w a -> T w a
clear a
n T w a
s

accessor :: (Enum a, Bits w) => a -> Acc.T (T w a) Bool
accessor :: a -> T (T w a) Bool
accessor a
x = (Bool -> T w a -> T w a) -> (T w a -> Bool) -> T (T w a) Bool
forall a r. (a -> r -> r) -> (r -> a) -> T r a
Acc.fromSetGet (a -> Bool -> T w a -> T w a
forall a w. (Enum a, Bits w) => a -> Bool -> T w a -> T w a
put a
x) (a -> T w a -> Bool
forall a w. (Enum a, Bits w) => a -> T w a -> Bool
get a
x)


{-# INLINE lift1 #-}
lift1 ::
   (Enum a, Bits w) =>
   (w -> Int -> w) -> (a -> T w a -> T w a)
lift1 :: (w -> Int -> w) -> a -> T w a -> T w a
lift1 w -> Int -> w
f a
n (Cons w
vec) = w -> T w a
forall word index. word -> T word index
Cons (w -> Int -> w
f w
vec (a -> Int
forall a. Enum a => a -> Int
P.fromEnum a
n))

singleton :: (Enum a, Bits w) => a -> T w a
singleton :: a -> T w a
singleton = (a -> T w a -> T w a) -> T w a -> a -> T w a
forall a b c. (a -> b -> c) -> b -> a -> c
P.flip a -> T w a -> T w a
forall a w. (Enum a, Bits w) => a -> T w a -> T w a
set T w a
forall a w. (Enum a, Bits w) => T w a
empty

-- | could also be named @insert@ like in @Set@
set :: (Enum a, Bits w) => a -> T w a -> T w a
set :: a -> T w a -> T w a
set = (w -> Int -> w) -> a -> T w a -> T w a
forall a w.
(Enum a, Bits w) =>
(w -> Int -> w) -> a -> T w a -> T w a
lift1 w -> Int -> w
forall a. Bits a => a -> Int -> a
B.setBit

-- | could also be named @delete@ like in @Set@
clear :: (Enum a, Bits w) => a -> T w a -> T w a
clear :: a -> T w a -> T w a
clear = (w -> Int -> w) -> a -> T w a -> T w a
forall a w.
(Enum a, Bits w) =>
(w -> Int -> w) -> a -> T w a -> T w a
lift1 w -> Int -> w
forall a. Bits a => a -> Int -> a
B.clearBit

flip :: (Enum a, Bits w) => a -> T w a -> T w a
flip :: a -> T w a -> T w a
flip = (w -> Int -> w) -> a -> T w a -> T w a
forall a w.
(Enum a, Bits w) =>
(w -> Int -> w) -> a -> T w a -> T w a
lift1 w -> Int -> w
forall a. Bits a => a -> Int -> a
B.complementBit

fromBool :: (Enum a, Bits w) => a -> Bool -> T w a
fromBool :: a -> Bool -> T w a
fromBool a
n Bool
b =
   w -> T w a
forall word index. word -> T word index
Cons (w -> T w a) -> w -> T w a
forall a b. (a -> b) -> a -> b
$ if Bool
b then Int -> w
forall a. Bits a => Int -> a
B.bit (a -> Int
forall a. Enum a => a -> Int
P.fromEnum a
n) else w
forall w. Bits w => w
U.empty
{- requires Num instance
   Cons (B.shiftL (fromIntegral $ P.fromEnum b) (P.fromEnum n))
-}