module System.Hardware.MercuryApi.ParamValue where
import Control.Applicative ( (<$>) )
import Control.Exception ( bracketOnError )
import qualified Data.ByteString as B ( useAsCString, length )
import Data.Text (Text)
import Data.Word ( Word8, Word16, Word32 )
import Foreign
( Int8,
Int16,
Int32,
Ptr,
Storable(peek, poke),
castPtr,
with,
toBool,
new,
fromBool,
free,
allocaBytes,
alloca )
import System.Hardware.MercuryApi.Enums
import System.Hardware.MercuryApi.Records
class ParamValue a where
pType :: a -> ParamType
pGet :: (Ptr () -> IO ()) -> IO a
pSet :: a -> (Ptr () -> IO ()) -> IO ()
instance ParamValue Bool where
pType _ = ParamTypeBool
pGet f = alloca $ \p -> f (castPtr (p :: Ptr CBool)) >> toBool <$> peek p
pSet x f = alloca $ \p -> poke p (fromBool x :: CBool) >> f (castPtr p)
instance ParamValue GEN2_WriteMode where
pType _ = ParamTypeGEN2_WriteMode
pGet f = alloca $ \p -> f (castPtr p) >> toWriteMode <$> peek p
pSet x f = alloca $ \p -> poke p (fromWriteMode x) >> f (castPtr p)
instance ParamValue Int16 where
pType _ = ParamTypeInt16
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = alloca $ \p -> poke p x >> f (castPtr p)
instance ParamValue Int32 where
pType _ = ParamTypeInt32
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = alloca $ \p -> poke p x >> f (castPtr p)
instance ParamValue Int8 where
pType _ = ParamTypeInt8
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = alloca $ \p -> poke p x >> f (castPtr p)
instance ParamValue PowerMode where
pType _ = ParamTypePowerMode
pGet f = alloca $ \p -> f (castPtr p) >> toPowerMode <$> peek p
pSet x f = alloca $ \p -> poke p (fromPowerMode x) >> f (castPtr p)
instance ParamValue ReadPlan where
pType _ = ParamTypeReadPlan
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = bracketOnError (new x) free (f . castPtr)
instance ParamValue Region where
pType _ = ParamTypeRegion
pGet f = alloca $ \p -> f (castPtr p) >> toRegion <$> peek p
pSet x f = alloca $ \p -> poke p (fromRegion x) >> f (castPtr p)
instance ParamValue TagProtocol where
pType _ = ParamTypeTagProtocol
pGet f = alloca $ \p -> f (castPtr p) >> toTagProtocol <$> peek p
pSet x f = alloca $ \p -> poke p (fromTagProtocol x) >> f (castPtr p)
instance ParamValue Text where
pType _ = ParamTypeText
pGet f = do
let maxLen = maxBound :: Word16
allocaBytes (fromIntegral maxLen) $ \storage -> do
let lst = List16
{ l16_list = castPtr storage
, l16_max = maxLen
, l16_len = 0
}
with lst $ \p -> do
f (castPtr p)
textFromCString storage
pSet x f = do
let bs = textToBS x
B.useAsCString bs $ \cs -> do
len' <- castLen "Text" (1 + B.length bs)
let lst = List16
{ l16_list = castPtr cs
, l16_max = len'
, l16_len = 0
}
with lst $ \p -> f (castPtr p)
instance ParamValue Word16 where
pType _ = ParamTypeWord16
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = alloca $ \p -> poke p x >> f (castPtr p)
instance ParamValue Word32 where
pType _ = ParamTypeWord32
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = alloca $ \p -> poke p x >> f (castPtr p)
instance ParamValue Word8 where
pType _ = ParamTypeWord8
pGet f = alloca $ \p -> f (castPtr p) >> peek p
pSet x f = alloca $ \p -> poke p x >> f (castPtr p)
instance ParamValue [MetadataFlag] where
pType _ = ParamTypeMetadataFlagList
pGet f = alloca $ \p -> f (castPtr p) >> unpackFlags <$> peek p
pSet x f = alloca $ \p -> poke p (packFlags x) >> f (castPtr p)
instance ParamValue [Region] where
pType _ = ParamTypeRegionList
pGet f = map toRegion <$> getList8 f
pSet x f = setList8 "[Region]" (map fromRegion x) f
instance ParamValue [TagProtocol] where
pType _ = ParamTypeTagProtocolList
pGet f = map toTagProtocol <$> getList8 f
pSet x f = setList8 "[TagProtocol]" (map fromTagProtocol x) f
instance ParamValue [Word32] where
pType _ = ParamTypeWord32List
pGet = getList16
pSet = setList16 "[Word32]"
instance ParamValue [Word8] where
pType _ = ParamTypeWord8List
pGet = getList16
pSet = setList16 "[Word8]"