module Development.Shake.Value(
Value, newValue, fromValue, typeValue,
Key, newKey, fromKey, typeKey,
Witness, currentWitness, registerWitness,
ShakeValue
) 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
type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a)
newtype Key = Key Value
deriving (Eq,Hashable,NFData,BinaryWith Witness)
data Value = forall a . ShakeValue a => Value a
newKey :: ShakeValue a => a -> Key
newKey = Key . newValue
newValue :: ShakeValue 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
witness :: IORef (Map.HashMap TypeRep Value)
witness = unsafePerformIO $ newIORef Map.empty
registerWitness :: ShakeValue 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)
toStableList :: Map.HashMap TypeRep v -> [(TypeRep,v)]
toStableList = sortBy (compare `on` show . fst) . Map.toList
data Witness = Witness
{typeNames :: [String]
,witnessIn :: Map.HashMap Word16 Value
,witnessOut :: Map.HashMap TypeRep Word16
} deriving Show
instance Eq Witness where
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
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 $
"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