module GHC.Iface.Ext.Fields
   ( ExtensibleFields (..)
   , FieldName
   , emptyExtensibleFields
   -- * Reading
   , readField
   , readFieldWith
   -- * Writing
   , writeField
   , writeFieldWith
   -- * Deletion
   , 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
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Map FieldName BinData -> Int
forall k a. Map k a -> Int
Map.size Map FieldName BinData
fs :: Int)

    -- Put the names of each field, and reserve a space
    -- for a payload pointer after each name:
    [(Bin (Bin Any), BinData)]
header_entries <- [(FieldName, BinData)]
-> ((FieldName, BinData) -> IO (Bin (Bin Any), BinData))
-> IO [(Bin (Bin Any), 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 (Bin Any), BinData))
 -> IO [(Bin (Bin Any), BinData)])
-> ((FieldName, BinData) -> IO (Bin (Bin Any), BinData))
-> IO [(Bin (Bin Any), BinData)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
name, BinData
dat) -> do
      BinHandle -> FieldName -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FieldName
name
      Bin (Bin Any)
field_p_p <- BinHandle -> IO (Bin (Bin Any))
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
      BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
field_p_p
      (Bin (Bin Any), BinData) -> IO (Bin (Bin Any), BinData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bin (Bin Any)
field_p_p, BinData
dat)

    -- Now put the payloads and use the reserved space
    -- to point to the start of each payload:
    [(Bin (Bin Any), BinData)]
-> ((Bin (Bin Any), BinData) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Bin (Bin Any), BinData)]
header_entries (((Bin (Bin Any), BinData) -> IO ()) -> IO ())
-> ((Bin (Bin Any), BinData) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Bin (Bin Any)
field_p_p, BinData
dat) -> do
      Bin Any
field_p <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
      BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
field_p_p Bin Any
field_p
      BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
field_p
      BinHandle -> BinData -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh BinData
dat

  get :: BinHandle -> IO ExtensibleFields
get BinHandle
bh = do
    Int
n <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int

    -- Get the names and field pointers:
    [(FieldName, Bin Any)]
header_entries <- Int -> IO (FieldName, Bin Any) -> IO [(FieldName, Bin Any)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (IO (FieldName, Bin Any) -> IO [(FieldName, Bin Any)])
-> IO (FieldName, Bin Any) -> IO [(FieldName, Bin Any)]
forall a b. (a -> b) -> a -> b
$
      (,) (FieldName -> Bin Any -> (FieldName, Bin Any))
-> IO FieldName -> IO (Bin Any -> (FieldName, Bin Any))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO FieldName
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (Bin Any -> (FieldName, Bin Any))
-> IO (Bin Any) -> IO (FieldName, Bin Any)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

    -- Seek to and get each field's payload:
    [(FieldName, BinData)]
fields <- [(FieldName, Bin Any)]
-> ((FieldName, Bin Any) -> IO (FieldName, BinData))
-> IO [(FieldName, BinData)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FieldName, Bin Any)]
header_entries (((FieldName, Bin Any) -> IO (FieldName, BinData))
 -> IO [(FieldName, BinData)])
-> ((FieldName, Bin Any) -> IO (FieldName, BinData))
-> IO [(FieldName, BinData)]
forall a b. (a -> b) -> a -> b
$ \(FieldName
name, Bin Any
field_p) -> do
      BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
field_p
      BinData
dat <- BinHandle -> IO BinData
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
      (FieldName, BinData) -> IO (FieldName, BinData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldName
name, BinData
dat)

    ExtensibleFields -> IO ExtensibleFields
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtensibleFields -> IO ExtensibleFields)
-> ([(FieldName, BinData)] -> ExtensibleFields)
-> [(FieldName, BinData)]
-> IO ExtensibleFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FieldName BinData -> ExtensibleFields
ExtensibleFields (Map FieldName BinData -> ExtensibleFields)
-> ([(FieldName, BinData)] -> Map FieldName BinData)
-> [(FieldName, BinData)]
-> ExtensibleFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FieldName, BinData)] -> Map FieldName BinData
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FieldName, BinData)] -> IO ExtensibleFields)
-> [(FieldName, BinData)] -> IO ExtensibleFields
forall a b. (a -> b) -> a -> b
$ [(FieldName, BinData)]
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

--------------------------------------------------------------------------------
-- | Reading

readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField :: forall a. Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
readField FieldName
name = FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
forall a.
FieldName
-> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
readFieldWith FieldName
name BinHandle -> IO a
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 = 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
$ ((BinHandle -> IO a
read (BinHandle -> IO a) -> IO BinHandle -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (IO BinHandle -> IO a)
-> (BinData -> IO BinHandle) -> BinData -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinData -> IO BinHandle
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)

--------------------------------------------------------------------------------
-- | Writing

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 (BinHandle -> a -> IO ()
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024)
  BinHandle -> IO ()
write BinHandle
bh
  --
  BinData
bd <- BinHandle -> IO BinData
handleData BinHandle
bh
  ExtensibleFields -> IO ExtensibleFields
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtensibleFields -> IO ExtensibleFields)
-> ExtensibleFields -> IO ExtensibleFields
forall a b. (a -> b) -> a -> b
$ Map FieldName BinData -> ExtensibleFields
ExtensibleFields (FieldName
-> BinData -> Map FieldName BinData -> Map FieldName BinData
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FieldName
name BinData
bd (Map FieldName BinData -> Map FieldName BinData)
-> Map FieldName BinData -> Map FieldName BinData
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 (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