{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Haskus.Format.Binary.Union
( Union
, fromUnion
, toUnion
, toUnionZero
)
where
import Haskus.Utils.Memory (memCopy, memSet)
import Haskus.Utils.Types hiding (Union)
import Haskus.Utils.HList
import Haskus.Utils.Flow (when)
import Haskus.Format.Binary.Storable
import Haskus.Format.Binary.Ptr
import System.IO.Unsafe (unsafePerformIO)
import qualified Foreign.Storable as FS
newtype Union (x :: [*]) = Union (ForeignPtr ()) deriving (Show)
fromUnion :: (Storable a, Member a l) => Union l -> a
fromUnion (Union fp) = unsafePerformIO $ withForeignPtr fp (peek . castPtr)
toUnion :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l
toUnion = toUnion' False
toUnionZero :: forall a l . (Storable (Union l), Storable a, Member a l) => a -> Union l
toUnionZero = toUnion' True
toUnion' :: forall a l . (Storable (Union l), Storable a, Member a l) => Bool -> a -> Union l
toUnion' zero v = unsafePerformIO $ do
let sz = sizeOfT @(Union l)
fp <- mallocForeignPtrBytes (fromIntegral sz)
withForeignPtr fp $ \p -> do
when zero $ do
let psz = sizeOfT @a
memSet (p `indexPtr'` psz) (fromIntegral (sz - psz)) 0
poke (castPtr p) v
return $ Union fp
type family MapSizeOf fs where
MapSizeOf '[] = '[]
MapSizeOf (x ': xs) = SizeOf x ': MapSizeOf xs
type family MapAlignment fs where
MapAlignment '[] = '[]
MapAlignment (x ': xs) = Alignment x ': MapAlignment xs
instance forall fs.
( KnownNat (ListMax (MapSizeOf fs))
, KnownNat (ListMax (MapAlignment fs))
)
=> StaticStorable (Union fs)
where
type SizeOf (Union fs) = ListMax (MapSizeOf fs)
type Alignment (Union fs) = ListMax (MapAlignment fs)
staticPeekIO ptr = do
let sz = natValue @(SizeOf (Union fs))
fp <- mallocForeignPtrBytes sz
withForeignPtr fp $ \p ->
memCopy p (castPtr ptr) (fromIntegral sz)
return (Union fp)
staticPokeIO ptr (Union fp) = do
withForeignPtr fp $ \p ->
memCopy (castPtr ptr) p (natValue @(SizeOf (Union fs)))
data FoldSizeOf = FoldSizeOf
data FoldAlignment = FoldAlignment
instance (r ~ Word, Storable a) => Apply FoldSizeOf (a, Word) r where
apply _ (_,r) = max r (sizeOfT @a)
instance (r ~ Word, Storable a) => Apply FoldAlignment (a, Word) r where
apply _ (_,r) = max r (alignmentT @a)
unionSize :: forall l . HFoldr' FoldSizeOf Word l Word => Union l -> Word
unionSize _ = hFoldr' FoldSizeOf (0 :: Word) (undefined :: HList l)
unionAlignment :: forall l . HFoldr' FoldAlignment Word l Word => Union l -> Word
unionAlignment _ = hFoldr' FoldAlignment (0 :: Word) (undefined :: HList l)
instance
( HFoldr' FoldSizeOf Word l Word
, HFoldr' FoldAlignment Word l Word
) => Storable (Union l) where
sizeOf = unionSize
alignment = unionAlignment
peekIO ptr = do
let sz = sizeOfT' @(Union l)
fp <- mallocForeignPtrBytes sz
withForeignPtr fp $ \p ->
memCopy p (castPtr ptr) (fromIntegral sz)
return (Union fp)
pokeIO ptr (Union fp) = withForeignPtr fp $ \p ->
memCopy (castPtr ptr) p (sizeOfT' @(Union l))
instance
( HFoldr' FoldSizeOf Word l Word
, HFoldr' FoldAlignment Word l Word
) => FS.Storable (Union l) where
sizeOf = fromIntegral . unionSize
alignment = fromIntegral . unionAlignment
peek = peekIO
poke = pokeIO