module GHC.Iface.Ext.Fields
( ExtensibleFields (..)
, FieldName
, emptyExtensibleFields
, readField
, readFieldWith
, writeField
, writeFieldWith
, deleteField
)
where
import GHC.Prelude
import GHC.Utils.Binary
import Control.Monad
import Data.Map ( Map )
import qualified Data.Map as Map
import Control.DeepSeq
type FieldName = String
newtype ExtensibleFields = ExtensibleFields { ExtensibleFields -> Map FieldName BinData
getExtensibleFields :: (Map FieldName BinData) }
instance Binary ExtensibleFields where
put_ :: WriteBinHandle -> ExtensibleFields -> IO ()
put_ WriteBinHandle
bh (ExtensibleFields Map FieldName BinData
fs) = do
WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Map FieldName BinData -> Int
forall k a. Map k a -> Int
Map.size Map FieldName BinData
fs :: Int)
header_entries <- [(FieldName, BinData)]
-> ((FieldName, BinData)
-> IO (Bin (RelBinPtr (ZonkAny 1)), BinData))
-> IO [(Bin (RelBinPtr (ZonkAny 1)), BinData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map FieldName BinData -> [(FieldName, BinData)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FieldName BinData
fs) (((FieldName, BinData)
-> IO (Bin (RelBinPtr (ZonkAny 1)), BinData))
-> IO [(Bin (RelBinPtr (ZonkAny 1)), BinData)])
-> ((FieldName, BinData)
-> IO (Bin (RelBinPtr (ZonkAny 1)), BinData))
-> IO [(Bin (RelBinPtr (ZonkAny 1)), BinData)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
name, BinData
dat) -> do
WriteBinHandle -> FieldName -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FieldName
name
field_p_p <- WriteBinHandle -> IO (Bin (RelBinPtr (ZonkAny 1)))
forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter WriteBinHandle
bh
put_ bh field_p_p
return (field_p_p, dat)
forM_ header_entries $ \(Bin (RelBinPtr (ZonkAny 1))
field_p_p, BinData
dat) -> do
field_p <- WriteBinHandle -> IO (Bin (ZonkAny 1))
forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter WriteBinHandle
bh
putAtRel bh field_p_p field_p
seekBinWriter bh field_p
put_ bh dat
get :: ReadBinHandle -> IO ExtensibleFields
get ReadBinHandle
bh = do
n <- ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh :: IO Int
header_entries <- replicateM n $
(,) <$> get bh <*> getRelBin bh
fields <- forM header_entries $ \(FieldName
name, RelBin (ZonkAny 3)
field_p) -> do
ReadBinHandle -> RelBin (ZonkAny 3) -> IO ()
forall {k} (a :: k). ReadBinHandle -> RelBin a -> IO ()
seekBinReaderRel ReadBinHandle
bh RelBin (ZonkAny 3)
field_p
dat <- ReadBinHandle -> IO BinData
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
return (name, dat)
return . ExtensibleFields . Map.fromList $ fields
instance NFData ExtensibleFields where
rnf :: ExtensibleFields -> ()
rnf (ExtensibleFields Map FieldName BinData
fs) = Map FieldName BinData -> ()
forall a. NFData a => a -> ()
rnf Map FieldName BinData
fs
emptyExtensibleFields :: ExtensibleFields
emptyExtensibleFields :: ExtensibleFields
emptyExtensibleFields = Map FieldName BinData -> ExtensibleFields
ExtensibleFields Map FieldName BinData
forall k a. Map k a
Map.empty
readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField :: forall a. Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField FieldName
name = FieldName
-> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
forall a.
FieldName
-> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get
readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith :: forall a.
FieldName
-> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name ReadBinHandle -> IO a
read ExtensibleFields
fields = Maybe (IO a) -> IO (Maybe a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Maybe (m a) -> m (Maybe a)
sequence (Maybe (IO a) -> IO (Maybe a)) -> Maybe (IO a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ((ReadBinHandle -> IO a
read (ReadBinHandle -> IO a) -> IO ReadBinHandle -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO ReadBinHandle -> IO a)
-> (BinData -> IO ReadBinHandle) -> BinData -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinData -> IO ReadBinHandle
dataHandle) (BinData -> IO a) -> Maybe BinData -> Maybe (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FieldName -> Map FieldName BinData -> Maybe BinData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
name (ExtensibleFields -> Map FieldName BinData
getExtensibleFields ExtensibleFields
fields)
writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField :: forall a.
Binary a =>
FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
writeField FieldName
name a
x = FieldName
-> (WriteBinHandle -> IO ())
-> ExtensibleFields
-> IO ExtensibleFields
writeFieldWith FieldName
name (WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
`put_` a
x)
writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith :: FieldName
-> (WriteBinHandle -> IO ())
-> ExtensibleFields
-> IO ExtensibleFields
writeFieldWith FieldName
name WriteBinHandle -> IO ()
write ExtensibleFields
fields = do
bh <- Int -> IO WriteBinHandle
openBinMem (Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
write bh
bd <- handleData bh
return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)
deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
deleteField FieldName
name (ExtensibleFields Map FieldName BinData
fs) = Map FieldName BinData -> ExtensibleFields
ExtensibleFields (Map FieldName BinData -> ExtensibleFields)
-> Map FieldName BinData -> ExtensibleFields
forall a b. (a -> b) -> a -> b
$ FieldName -> Map FieldName BinData -> Map FieldName BinData
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
name Map FieldName BinData
fs