codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
{-# 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)
Private
[
?
]
Run code
Submit