This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap".
The branch, master has been updated
via f0472cdcb9767792369303edd8362f92424ef72d (commit)
from 7f486cae69b8c34bcf4089ef2add5bef711926b0 (commit)
Summary of changes:
src/Snap/Extension.hs | 25 ++++++++----------
src/Snap/Extension/Loader/Devel.hs | 14 ++++++----
src/Snap/Extension/Loader/Devel/Evaluator.hs | 35 +++++++------------------
3 files changed, 29 insertions(+), 45 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f0472cdcb9767792369303edd8362f92424ef72d
Author: Carl Howells <[email protected]>
Date: Thu Dec 23 14:13:17 2010 -0800
Generalize some methods, and simplify the hint loader
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
index 1f5f8a4..e58a9dc 100644
--- a/src/Snap/Extension.hs
+++ b/src/Snap/Extension.hs
@@ -25,7 +25,7 @@ module Snap.Extension
, InitializerState(..)
, runInitializer
, runInitializerWithReloadAction
- , getHintInternals
+ , runInitializerWithoutReloadAction
, mkInitializer
, defaultReloadHandler
, nullReloadHandler
@@ -43,7 +43,6 @@ import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Prelude hiding (catch, init)
-import Snap.Extension.Loader.Devel.Evaluator
import Snap.Iteratee (enumBS, (>==>))
import Snap.Types
import System.IO
@@ -408,18 +407,16 @@ runInitializerWithReloadAction v (Initializer r) se f = do
Right (SCR s a b) -> return (s, a, b)
------------------------------------------------------------------------------
--- | Translates an Initializer and SnapExtend into a HintInternals
--- object, used by the hint loading code.
-getHintInternals :: Initializer s
- -- ^ The Initializer value
- -> SnapExtend s ()
- -- ^ An action in your application's monad.
- -> HintInternals
-getHintInternals i se = HintInternals runInit getCleanup getAction
- where
- runInit = runInitializer True i se
- getAction (action, _, _) = action
- getCleanup (_, cleanup, _) = cleanup
+-- | A cut-down version of 'runInitializer', for use by the hint
+-- loading code
+runInitializerWithoutReloadAction :: Initializer s
+ -- ^ The Initializer value
+ -> SnapExtend s ()
+ -- ^ An action in your application's monad.
+ -> IO (Snap (), IO ())
+runInitializerWithoutReloadAction i se = do
+ (action, cleanup, _) <- runInitializer True i se
+ return (action, cleanup)
------------------------------------------------------------------------------
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index bf79506..7111da9 100644
--- a/src/Snap/Extension/Loader/Devel.hs
+++ b/src/Snap/Extension/Loader/Devel.hs
@@ -22,7 +22,7 @@ import System.Environment (getArgs)
------------------------------------------------------------------------------
import Snap.Types
-import Snap.Extension (getHintInternals)
+import Snap.Extension (runInitializerWithoutReloadAction)
import Snap.Extension.Loader.Devel.Signal
import Snap.Extension.Loader.Devel.Evaluator
@@ -59,7 +59,8 @@ loadSnapTH initializer action = do
-- The let in this block causes an extra static type check that the
-- types of the names passed in were correct at compile time.
- [| let _ = getHintInternals $(varE initializer) $(varE action)
+ [| let _ = runInitializerWithoutReloadAction $(varE initializer)
+ $(varE action)
in hintSnap opts modules initBase actBase |]
@@ -115,18 +116,19 @@ hintSnap :: [String] -- ^ A list of command-line options
for the interpreter
-> String -- ^ The name of the SnapExtend action
-> IO (Snap ())
hintSnap opts modules initialization handler = do
- let action = intercalate " " [ "getHintInternals"
+ let action = intercalate " " [ "runInitializerWithoutReloadAction"
, initialization
, handler
]
interpreter = do
loadModules . nub $ modules
- let imports = "Snap.Extension" :
- "Snap.Extension.Loader.Devel.Evaluator" :
+ let imports = "Prelude" :
+ "Snap.Extension" :
+ "Snap.Types" :
modules
setImports . nub $ imports
- interpret action (as :: HintInternals)
+ interpret action (as :: HintLoadable)
loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs
b/src/Snap/Extension/Loader/Devel/Evaluator.hs
index 0122f9f..f286ae4 100644
--- a/src/Snap/Extension/Loader/Devel/Evaluator.hs
+++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs
@@ -1,9 +1,7 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Extension.Loader.Devel.Evaluator
- ( HintInternals(..)
+ ( HintLoadable
, protectedHintEvaluator
) where
@@ -15,27 +13,14 @@ import Control.Monad.Trans (liftIO)
import Control.Concurrent (ThreadId, forkIO, myThreadId)
import Control.Concurrent.MVar
-import Data.Typeable (Typeable)
-
import Prelude hiding (catch, init, any)
import Snap.Types (Snap)
------------------------------------------------------------------------------
--- | A monomorphic type to hide polymorphism. This allows Hint to
--- load the action, since it requires loading a monomorphic type.
-data HintInternals = forall a. HintInternals (IO a) (a -> IO ()) (a -> Snap ())
- deriving Typeable
-
-
-------------------------------------------------------------------------------
--- | Run the initialization contained within a HintInternals, and return the
--- Snap handler and cleanup action that result.
-initInternals :: HintInternals -> IO (IO (), Snap ())
-initInternals (HintInternals init clean exec) = do
- state <- init
- return (clean state, exec state)
+-- | A type synonym to simply talking about the type loaded by hint.
+type HintLoadable = IO (Snap (), IO ())
------------------------------------------------------------------------------
@@ -57,7 +42,7 @@ initInternals (HintInternals init clean exec) = do
protectedHintEvaluator :: forall a.
IO a
-> (a -> IO Bool)
- -> IO HintInternals
+ -> IO HintLoadable
-> IO (Snap ())
protectedHintEvaluator start test getInternals = do
-- The list of requesters waiting for a result. Contains the
@@ -101,10 +86,10 @@ protectedHintEvaluator start test getInternals = do
unblock $ cleanup previous
-- compile the new internals and initialize
- hi <- unblock getInternals
- res <- unblock $ initInternals hi
+ stateInitializer <- unblock getInternals
+ res <- unblock stateInitializer
- let a = snd res
+ let a = fst res
clearAndNotify (Right res) (flip putMVar a . snd)
@@ -133,7 +118,7 @@ protectedHintEvaluator start test getInternals = do
-- There's an existing result. Check for validity
valid <- test a
case (valid, res) of
- (True, Right (_, x)) -> return x
+ (True, Right (x, _)) -> return x
(True, Left e) -> throwIO e
(False, _) -> do
_ <- swapMVar resultContainer Nothing
@@ -145,8 +130,8 @@ protectedHintEvaluator start test getInternals = do
newReaderContainer = newMVar []
newResultContainer :: IO (MVar (Maybe (Either SomeException
- (IO (), Snap ()), a)))
+ (Snap (), IO ()), a)))
newResultContainer = newMVar Nothing
- cleanup (Just (Right (clean, _), _)) = clean
+ cleanup (Just (Right (_, clean), _)) = clean
cleanup _ = return ()
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
