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_ :: BinHandle -> ExtensibleFields -> IO ()
put_ BinHandle
bh (ExtensibleFields Map FieldName BinData
fs) = do
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall k a. Map k a -> Int
Map.size Map FieldName BinData
fs :: Int)
[(Bin (Bin Any), BinData)]
header_entries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map FieldName BinData
fs) forall a b. (a -> b) -> a -> b
$ \(FieldName
name, BinData
dat) -> do
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FieldName
name
Bin (Bin Any)
field_p_p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
field_p_p
forall (m :: * -> *) a. Monad m => a -> m a
return (Bin (Bin Any)
field_p_p, BinData
dat)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Bin (Bin Any), BinData)]
header_entries forall a b. (a -> b) -> a -> b
$ \(Bin (Bin Any)
field_p_p, BinData
dat) -> do
Bin Any
field_p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
field_p_p Bin Any
field_p
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
field_p
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh BinData
dat
get :: BinHandle -> IO ExtensibleFields
get BinHandle
bh = do
Int
n <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
[(FieldName, Bin Any)]
header_entries <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n forall a b. (a -> b) -> a -> b
$
(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
[(FieldName, BinData)]
fields <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FieldName, Bin Any)]
header_entries forall a b. (a -> b) -> a -> b
$ \(FieldName
name, Bin Any
field_p) -> do
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
field_p
BinData
dat <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldName
name, BinData
dat)
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FieldName BinData -> ExtensibleFields
ExtensibleFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [(FieldName, BinData)]
fields
instance NFData ExtensibleFields where
rnf :: ExtensibleFields -> ()
rnf (ExtensibleFields Map FieldName BinData
fs) = forall a. NFData a => a -> ()
rnf Map FieldName BinData
fs
emptyExtensibleFields :: ExtensibleFields
emptyExtensibleFields :: ExtensibleFields
emptyExtensibleFields = Map FieldName BinData -> ExtensibleFields
ExtensibleFields 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 = forall a.
FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name forall a. Binary a => BinHandle -> IO a
get
readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith :: forall a.
FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name BinHandle -> IO a
read ExtensibleFields
fields = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ ((BinHandle -> IO a
read forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinData -> IO BinHandle
dataHandle) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
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
-> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith FieldName
name (forall a. Binary a => BinHandle -> a -> IO ()
`put_` a
x)
writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith :: FieldName
-> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
writeFieldWith FieldName
name BinHandle -> IO ()
write ExtensibleFields
fields = do
BinHandle
bh <- Int -> IO BinHandle
openBinMem (Int
1024 forall a. Num a => a -> a -> a
* Int
1024)
BinHandle -> IO ()
write BinHandle
bh
BinData
bd <- BinHandle -> IO BinData
handleData BinHandle
bh
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map FieldName BinData -> ExtensibleFields
ExtensibleFields (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
name BinData
bd forall a b. (a -> b) -> a -> b
$ ExtensibleFields -> Map FieldName BinData
getExtensibleFields ExtensibleFields
fields)
deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
deleteField FieldName
name (ExtensibleFields Map FieldName BinData
fs) = Map FieldName BinData -> ExtensibleFields
ExtensibleFields forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FieldName
name Map FieldName BinData
fs