Initial open source import

Author: Simon Marlow

.gitignore

@@ -0,0 +1,4 @@
+.cabal-sandbox
+cabal.sandbox.config
+dist
+*~

Haxl/Core.hs

@@ -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

Haxl/Core/DataCache.hs

@@ -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)))

Haxl/Core/Env.hs

@@ -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