1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
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 <- tellBin 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 <- tellBin bh
putAt bh field_p_p field_p
seekBin 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 <*> get bh
-- Seek to and get each field's payload:
fields <- forM header_entries $ \(name, field_p) -> do
seekBin 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 -> (BinHandle -> 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 -> (BinHandle -> 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
|
