module Haxl.Core.DataCache
( DataCache
, empty
, insert
, lookup
, showCache
) where
import Data.HashMap.Strict (HashMap)
import Data.Hashable
import Prelude hiding (lookup)
import Unsafe.Coerce
import qualified Data.HashMap.Strict as HashMap
import Data.Typeable.Internal
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative hiding (empty)
#endif
import Control.Exception
import Haxl.Core.Types
newtype DataCache res = DataCache (HashMap TypeRep (SubCache res))
data SubCache res =
forall req a . (Hashable (req a), Eq (req a), Show (req a), Show a) =>
SubCache ! (HashMap (req a) (res a))
empty :: DataCache res
empty = DataCache HashMap.empty
insert
:: (Hashable (req a), Typeable (req a), Eq (req a), Show (req a), Show a)
=> req a
-> res a
-> DataCache res
-> DataCache res
insert req result (DataCache m) =
DataCache $
HashMap.insertWith fn (typeOf req)
(SubCache (HashMap.singleton req result)) m
where
fn (SubCache new) (SubCache old) =
SubCache (unsafeCoerce new `HashMap.union` old)
lookup
:: Typeable (req a)
=> req a
-> DataCache res
-> Maybe (res a)
lookup req (DataCache m) =
case HashMap.lookup (typeOf req) m of
Nothing -> Nothing
Just (SubCache sc) ->
unsafeCoerce (HashMap.lookup (unsafeCoerce req) sc)
showCache
:: DataCache ResultVar
-> IO [(TypeRep, [(String, Either SomeException String)])]
showCache (DataCache cache) = mapM goSubCache (HashMap.toList cache)
where
goSubCache
:: (TypeRep,SubCache ResultVar)
-> IO (TypeRep,[(String, Either SomeException String)])
goSubCache (ty, SubCache hmap) = do
elems <- catMaybes <$> mapM go (HashMap.toList hmap)
return (ty, elems)
go :: (Show (req a), Show a)
=> (req a, ResultVar a)
-> IO (Maybe (String, Either SomeException String))
go (req, rvar) = do
maybe_r <- tryReadResult rvar
case maybe_r of
Nothing -> return Nothing
Just (Left e) -> return (Just (show req, Left e))
Just (Right result) -> return (Just (show req, Right (show result)))