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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
{- |
This module implements the Key/Value types, to abstract over hetrogenous data types.
-}
module Development.Shake.Value(
Value, newValue, fromValue, typeValue,
Key, newKey, fromKey, typeKey,
Witness, currentWitness, registerWitness
) where
import General.Binary
import Development.Shake.Classes
import Development.Shake.Errors
import Data.Typeable
import Data.Bits
import Data.Function
import Data.IORef
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
import qualified Data.ByteString.Char8 as BS
import System.IO.Unsafe
-- We deliberately avoid Typeable instances on Key/Value to stop them accidentally
-- being used inside themselves
newtype Key = Key Value
deriving (Eq,Hashable,NFData,BinaryWith Witness)
data Value = forall a . (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => Value a
newKey :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> Key
newKey = Key . newValue
newValue :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> Value
newValue = Value
typeKey :: Key -> TypeRep
typeKey (Key v) = typeValue v
typeValue :: Value -> TypeRep
typeValue (Value x) = typeOf x
fromKey :: Typeable a => Key -> a
fromKey (Key v) = fromValue v
fromValue :: Typeable a => Value -> a
fromValue (Value x) = fromMaybe (err "fromValue, bad cast") $ cast x
instance Show Key where
show (Key a) = show a
instance Show Value where
show (Value a) = show a
instance NFData Value where
rnf (Value a) = rnf a
instance Hashable Value where
hashWithSalt salt (Value a) = hashWithSalt salt (typeOf a) `xor` hashWithSalt salt a
instance Eq Value where
Value a == Value b = maybe False (a ==) $ cast b
Value a /= Value b = maybe True (a /=) $ cast b
---------------------------------------------------------------------
-- BINARY INSTANCES
{-# NOINLINE witness #-}
witness :: IORef (Map.HashMap TypeRep Value)
witness = unsafePerformIO $ newIORef Map.empty
registerWitness :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> IO ()
registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ err msg `asTypeOf` x) mp, ())
where msg = "registerWitness, type " ++ show (typeOf x)
-- Produce a list in a predictable order from a Map TypeRep, which should be consistent regardless of the order
-- elements were added and stable between program executions.
-- Cannot rely on hash (not pure in hashable-1.2) or compare (not available before 7.2)
toStableList :: Map.HashMap TypeRep v -> [(TypeRep,v)]
toStableList = sortBy (compare `on` show . fst) . Map.toList
data Witness = Witness
{typeNames :: [String] -- the canonical data, the names of the types
,witnessIn :: Map.HashMap Word16 Value -- for reading in, the find the values (some may be missing)
,witnessOut :: Map.HashMap TypeRep Word16 -- for writing out, find the value
} deriving Show
instance Eq Witness where
-- Type names are produced by toStableList so should to remain consistent
-- regardless of the order of registerWitness calls.
a == b = typeNames a == typeNames b
currentWitness :: IO Witness
currentWitness = do
ws <- readIORef witness
let (ks,vs) = unzip $ toStableList ws
return $ Witness (map show ks) (Map.fromList $ zip [0..] vs) (Map.fromList $ zip ks [0..])
instance Binary Witness where
put (Witness ts _ _) = put $ BS.unlines $ map BS.pack ts
get = do
ts <- fmap (map BS.unpack . BS.lines) get
let ws = toStableList $ unsafePerformIO $ readIORefAfter ts witness
let (is,ks,vs) = unzip3 [(i,k,v) | (i,t) <- zip [0..] ts, (k,v):_ <- [filter ((==) t . show . fst) ws]]
return $ Witness ts (Map.fromList $ zip is vs) (Map.fromList $ zip ks is)
where
-- Read an IORef after examining a variable, used to avoid GHC over-optimisation
{-# NOINLINE readIORefAfter #-}
readIORefAfter :: a -> IORef b -> IO b
readIORefAfter v ref = v `seq` readIORef ref
instance BinaryWith Witness Value where
putWith ws (Value x) = do
let msg = "no witness for " ++ show (typeOf x)
put $ fromMaybe (error msg) $ Map.lookup (typeOf x) (witnessOut ws)
put x
getWith ws = do
h <- get
case Map.lookup h $ witnessIn ws of
Nothing | h >= 0 && h < genericLength (typeNames ws) -> error $
"Failed to find a type " ++ (typeNames ws !! fromIntegral h) ++ " which is stored in the database.\n" ++
"The most likely cause is that your build tool has changed significantly."
Nothing -> error $
-- should not happen, unless proper data corruption
"Corruption when reading Value, got type " ++ show h ++ ", but should be in range 0.." ++ show (length (typeNames ws) - 1)
Just (Value t) -> do
x <- get
return $ Value $ x `asTypeOf` t
|
