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
import Control.Applicative hiding (empty)
import Control.Exception
import Haxl.Core.Types
newtype DataCache = DataCache (HashMap TypeRep SubCache)
data SubCache =
forall req a . (Hashable (req a), Eq (req a), Show (req a), Show a) =>
SubCache ! (HashMap (req a) (ResultVar a))
empty :: DataCache
empty = DataCache HashMap.empty
insert
:: (Hashable (r a), Typeable (r a), Eq (r a), Show (r a), Show a)
=> r a
-> ResultVar a
-> DataCache
-> DataCache
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 (r a)
=> r a
-> DataCache
-> Maybe (ResultVar 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
-> IO [(TypeRep, [(String, Either SomeException String)])]
showCache (DataCache cache) = mapM goSubCache (HashMap.toList cache)
where
goSubCache
:: (TypeRep,SubCache)
-> 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)))