never executed always true always false

    1 module GHC.Iface.Ext.Fields
    2    ( ExtensibleFields (..)
    3    , FieldName
    4    , emptyExtensibleFields
    5    -- * Reading
    6    , readField
    7    , readFieldWith
    8    -- * Writing
    9    , writeField
   10    , writeFieldWith
   11    -- * Deletion
   12    , deleteField
   13    )
   14 where
   15 
   16 import GHC.Prelude
   17 import GHC.Utils.Binary
   18 
   19 import Control.Monad
   20 import Data.Map         ( Map )
   21 import qualified Data.Map as Map
   22 import Control.DeepSeq
   23 
   24 type FieldName = String
   25 
   26 newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }
   27 
   28 instance Binary ExtensibleFields where
   29   put_ bh (ExtensibleFields fs) = do
   30     put_ bh (Map.size fs :: Int)
   31 
   32     -- Put the names of each field, and reserve a space
   33     -- for a payload pointer after each name:
   34     header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
   35       put_ bh name
   36       field_p_p <- tellBin bh
   37       put_ bh field_p_p
   38       return (field_p_p, dat)
   39 
   40     -- Now put the payloads and use the reserved space
   41     -- to point to the start of each payload:
   42     forM_ header_entries $ \(field_p_p, dat) -> do
   43       field_p <- tellBin bh
   44       putAt bh field_p_p field_p
   45       seekBin bh field_p
   46       put_ bh dat
   47 
   48   get bh = do
   49     n <- get bh :: IO Int
   50 
   51     -- Get the names and field pointers:
   52     header_entries <- replicateM n $
   53       (,) <$> get bh <*> get bh
   54 
   55     -- Seek to and get each field's payload:
   56     fields <- forM header_entries $ \(name, field_p) -> do
   57       seekBin bh field_p
   58       dat <- get bh
   59       return (name, dat)
   60 
   61     return . ExtensibleFields . Map.fromList $ fields
   62 
   63 instance NFData ExtensibleFields where
   64   rnf (ExtensibleFields fs) = rnf fs
   65 
   66 emptyExtensibleFields :: ExtensibleFields
   67 emptyExtensibleFields = ExtensibleFields Map.empty
   68 
   69 --------------------------------------------------------------------------------
   70 -- | Reading
   71 
   72 readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
   73 readField name = readFieldWith name get
   74 
   75 readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
   76 readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
   77   Map.lookup name (getExtensibleFields fields)
   78 
   79 --------------------------------------------------------------------------------
   80 -- | Writing
   81 
   82 writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
   83 writeField name x = writeFieldWith name (`put_` x)
   84 
   85 writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
   86 writeFieldWith name write fields = do
   87   bh <- openBinMem (1024 * 1024)
   88   write bh
   89   --
   90   bd <- handleData bh
   91   return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)
   92 
   93 deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
   94 deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs