content: 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 { getExtensibleFields :: (Map FieldName BinData) }
  
  instance Binary ExtensibleFields where
    put_ bh (ExtensibleFields fs) = do
      put_ bh (Map.size fs :: Int)
  
      -- Put the names of each field, and reserve a space
      -- for a payload pointer after each name:
      header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
        put_ bh name
        field_p_p <- tellBinWriter bh
        put_ bh field_p_p
        return (field_p_p, dat)
  
      -- Now put the payloads and use the reserved space
      -- to point to the start of each payload:
      forM_ header_entries $ \(field_p_p, dat) -> do
        field_p <- tellBinWriter bh
        putAtRel bh field_p_p field_p
        seekBinWriter bh field_p
        put_ bh dat
  
    get bh = do
      n <- get bh :: IO Int
  
      -- Get the names and field pointers:
      header_entries <- replicateM n $
        (,) <$> get bh <*> getRelBin bh
  
      -- Seek to and get each field's payload:
      fields <- forM header_entries $ \(name, field_p) -> do
        seekBinReaderRel bh field_p
        dat <- get bh
        return (name, dat)
  
      return . ExtensibleFields . Map.fromList $ fields
  
  instance NFData ExtensibleFields where
    rnf (ExtensibleFields fs) = rnf fs
  
  emptyExtensibleFields :: ExtensibleFields
  emptyExtensibleFields = ExtensibleFields Map.empty
  
  --------------------------------------------------------------------------------
  -- | Reading
  
  readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
  readField name = readFieldWith name get
  
  readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
  readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
    Map.lookup name (getExtensibleFields fields)
  
  --------------------------------------------------------------------------------
  -- | Writing
  
  writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
  writeField name x = writeFieldWith name (`put_` x)
  
  writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
  writeFieldWith name write fields = do
    bh <- openBinMem (1024 * 1024)
    write bh
    --
    bd <- handleData bh
    return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)
  
  deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
  deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs
  