{-# OPTIONS_GHC   -Wall                #-}
{-# LANGUAGE      ScopedTypeVariables
                  , TypeFamilies
                  , FlexibleContexts   #-}

module BitField where

import Control.Monad
--import Control.Applicative
import Data.Bits
import Foreign.Ptr
import Foreign.Storable

class (Storable (CType bitField), Bits (CType bitField))
      => BitField bitField where
   type CType bitField :: *
   size           :: bitField -> Int
   startPosition  :: bitField -> Int
   cSymbol        :: bitField -> Ptr (CType bitField)

   valueOf        :: bitField -> IO (CType bitField)
   valueOf        =  peek . cSymbol

   value          :: bitField -> IO [Bool]
   value n        =  liftM (\v -> bits v (startPosition n) (size n))
                           (valueOf n)

   setValueBit    :: bitField -> Int -> Bool -> IO (CType bitField)
   setValueBit n pos flag
      | pos >= (sizeOf (undefined::CType bitField))
         = error $ "bit Position: "     ++ show pos
                    ++ " >= (size n) :" ++ show (size n)
      | flag
         = modifyValue setBit
      | otherwise
         = modifyValue clearBit
      where modifyValue f = valueOf n
                            >>= (\x -> return $ f x pos)
                          -- could use the below instead of the above
                           --(flip f pos) <$> (valueOf n)
                            >>= poke (cSymbol n)
                            >> valueOf n

   setValue      :: bitField -> [Bool] -> IO [Bool]
   setValue n flags
      | (length flags) > (sizeOf $ cSymbol n)
         = error $ "(length flags) "  ++ show (length flags)
                   ++ " > (size n) :" ++ show (size n)
      | otherwise
         = zipWithM (setValueBit n) [(startPosition n)..] flags
           >> value n

bits           :: Bits a => a -> Int -> Int -> [Bool]
bits _ _   0   = []
bits i pos len = (testBit i pos) : bits i (succ pos) (pred len)