-
Notifications
You must be signed in to change notification settings - Fork 314
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Simon Marlow
committed
Jun 10, 2014
0 parents
commit 74a3874
Showing
44 changed files
with
3,928 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,4 @@ | ||
.cabal-sandbox | ||
cabal.sandbox.config | ||
dist | ||
*~ |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,24 @@ | ||
-- Copyright (c) 2014, Facebook, Inc. | ||
-- All rights reserved. | ||
-- | ||
-- This source code is distributed under the terms of a BSD license, | ||
-- found in the LICENSE file. An additional grant of patent rights can | ||
-- be found in the PATENTS file. | ||
|
||
-- | Everything needed to define data sources and to invoke the | ||
-- engine. This module should not be imported by user code. | ||
module Haxl.Core | ||
( module Haxl.Core.Env | ||
, module Haxl.Core.Monad | ||
, module Haxl.Core.Types | ||
, module Haxl.Core.Exception | ||
, module Haxl.Core.StateStore | ||
, module Haxl.Core.Show1 | ||
) where | ||
|
||
import Haxl.Core.Env | ||
import Haxl.Core.Monad hiding (unsafeLiftIO {- Ask nicely to get this! -}) | ||
import Haxl.Core.Types | ||
import Haxl.Core.Exception | ||
import Haxl.Core.Show1 (Show1(..)) | ||
import Haxl.Core.StateStore |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,113 @@ | ||
-- Copyright (c) 2014, Facebook, Inc. | ||
-- All rights reserved. | ||
-- | ||
-- This source code is distributed under the terms of a BSD license, | ||
-- found in the LICENSE file. An additional grant of patent rights can | ||
-- be found in the PATENTS file. | ||
|
||
{-# LANGUAGE ExistentialQuantification #-} | ||
{-# LANGUAGE RankNTypes #-} | ||
{-# OPTIONS_GHC -fno-warn-orphans #-} | ||
|
||
-- | A cache mapping data requests to their results. | ||
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 | ||
|
||
-- | The 'DataCache' maps things of type @f a@ to @'ResultVar' a@, for | ||
-- any @f@ and @a@ provided @f a@ is an instance of 'Typeable'. In | ||
-- practice @f a@ will be a request type parameterised by its result. | ||
-- | ||
-- See the definition of 'ResultVar' for more details. | ||
|
||
newtype DataCache = DataCache (HashMap TypeRep SubCache) | ||
|
||
-- | The implementation is a two-level map: the outer level maps the | ||
-- types of requests to 'SubCache', which maps actual requests to their | ||
-- results. So each 'SubCache' contains requests of the same type. | ||
-- This works well because we only have to store the dictionaries for | ||
-- 'Hashable' and 'Eq' once per request type. | ||
data SubCache = | ||
forall req a . (Hashable (req a), Eq (req a), Show (req a), Show a) => | ||
SubCache ! (HashMap (req a) (ResultVar a)) | ||
-- NB. the inner HashMap is strict, to avoid building up | ||
-- a chain of thunks during repeated insertions. | ||
|
||
-- | A new, empty 'DataCache'. | ||
empty :: DataCache | ||
empty = DataCache HashMap.empty | ||
|
||
-- | Inserts a request-result pair into the 'DataCache'. | ||
insert | ||
:: (Hashable (r a), Typeable (r a), Eq (r a), Show (r a), Show a) | ||
=> r a | ||
-- ^ Request | ||
-> ResultVar a | ||
-- ^ Result | ||
-> 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) | ||
|
||
-- | Looks up the cached result of a request. | ||
lookup | ||
:: Typeable (r a) | ||
=> r a | ||
-- ^ Request | ||
-> 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) | ||
|
||
-- | Dumps the contents of the cache, with requests and responses | ||
-- converted to 'String's using 'show'. The entries are grouped by | ||
-- 'TypeRep'. | ||
-- | ||
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))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,65 @@ | ||
-- Copyright (c) 2014, Facebook, Inc. | ||
-- All rights reserved. | ||
-- | ||
-- This source code is distributed under the terms of a BSD license, | ||
-- found in the LICENSE file. An additional grant of patent rights can | ||
-- be found in the PATENTS file. | ||
|
||
{-# LANGUAGE OverloadedStrings #-} | ||
|
||
-- | The Haxl monad environment. | ||
module Haxl.Core.Env | ||
( Env(..) | ||
, emptyEnv | ||
, initEnv | ||
, initEnvWithData | ||
, caches | ||
) where | ||
|
||
import Haxl.Core.DataCache as DataCache | ||
import Haxl.Core.StateStore | ||
import Haxl.Core.Types | ||
|
||
import Data.IORef | ||
|
||
-- | The data we carry around in the Haxl monad. | ||
data Env u = Env | ||
{ cacheRef :: IORef DataCache -- cached data fetches | ||
, memoRef :: IORef DataCache -- memoized computations | ||
, flags :: Flags | ||
, userEnv :: u | ||
, statsRef :: IORef Stats | ||
, states :: StateStore | ||
-- ^ Data sources and other components can store their state in | ||
-- here. Items in this store must be instances of 'StateKey'. | ||
} | ||
|
||
type Caches = (IORef DataCache, IORef DataCache) | ||
|
||
caches :: Env u -> Caches | ||
caches env = (cacheRef env, memoRef env) | ||
|
||
-- | Initialize an environment with a 'StateStore', an input map, a | ||
-- preexisting 'DataCache', and a seed for the random number generator. | ||
initEnvWithData :: StateStore -> u -> Caches -> IO (Env u) | ||
initEnvWithData states e (cref, mref) = do | ||
sref <- newIORef emptyStats | ||
return Env | ||
{ cacheRef = cref | ||
, memoRef = mref | ||
, flags = defaultFlags | ||
, userEnv = e | ||
, states = states | ||
, statsRef = sref | ||
} | ||
|
||
-- | Initializes an environment with 'DataStates' and an input map. | ||
initEnv :: StateStore -> u -> IO (Env u) | ||
initEnv states e = do | ||
cref <- newIORef DataCache.empty | ||
mref <- newIORef DataCache.empty | ||
initEnvWithData states e (cref,mref) | ||
|
||
-- | A new, empty environment. | ||
emptyEnv :: u -> IO (Env u) | ||
emptyEnv = initEnv stateEmpty |
Oops, something went wrong.