{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ScopedTypeVariables #-}

module BitField where

import Control.Monad
import Control.Applicative
import Data.Bits
import Foreign.Ptr
import Foreign.Storable hiding (sizeOf)
import Data.StateVar

class BitField bitField where
   sizeOf         :: bitField -> Int
   --belongsTo      :: (Storable a, Bits a) => bitField -> a
   startPosition  :: bitField -> Int
   cSymbol        :: (Storable a, Bits a) => bitField -> Ptr a
   -- the below definition gives ambiguous type variable errors
   --valueOf      :: forall a . (Storable a, Bits a) => bitField -> IO a
   --valueOf      =  peek . cSymbol
   value          :: bitField -> IO [Bool]
   value n =
      do let v = makeStateVar (peek $ cSymbol n) (poke $ cSymbol n)
         x <- get v
         let bits :: Bits a => a -> Int -> Int -> [Bool]
             bits _ _        0   = []
             bits n position len = (testBit n position)
                                   : bits n (succ position) (pred len)
         return $ bits x (startPosition n) (sizeOf n)
   addBit         :: (Storable a, Bits a) =>
                     bitField -> Int -> Bool -> IO a
   addBit n pos flag
      | pos >= (sizeOf n) = error $ "bit Position: "
                                          ++ show pos
                                          ++ " >= (sizeOf n) :"
                                          ++ show (sizeOf n)
      | flag                   = value setBit
      | otherwise              = value clearBit
      where valueOf     = peek . cSymbol
            value 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)
   addBits      :: (Storable a, Bits a) => bitField -> [Bool] -> IO a
   addBits n flags
      | (length flags) > (sizeOf n)
         = error $ "(length flags) "          ++ show (length flags)
                   ++ " > (sizeOf n) :" ++ show (sizeOf n)
      | otherwise
         = zipWithM (addBit n) [0..] flags >>= (\x -> return $ last x)