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 297f61856bc7d4ab660f6781303a973ee87cdf21 (commit)
from 25d1c25d8019cb9ed08c074d10b9b46291b42156 (commit)
Summary of changes:
src/Snap/Extension/Loader/Devel.hs | 9 +++--
src/Snap/Extension/Loader/Devel/Evaluator.hs | 51 +++++++++++++++-----------
2 files changed, 35 insertions(+), 25 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 297f61856bc7d4ab660f6781303a973ee87cdf21
Author: Carl Howells <[email protected]>
Date: Wed Dec 22 00:34:58 2010 -0800
Refactor the Evaluator code a bit, to abstract out logic for determining
when to recompile
diff --git a/src/Snap/Extension/Loader/Devel.hs
b/src/Snap/Extension/Loader/Devel.hs
index 5332968..0299807 100644
--- a/src/Snap/Extension/Loader/Devel.hs
+++ b/src/Snap/Extension/Loader/Devel.hs
@@ -12,15 +12,14 @@ module Snap.Extension.Loader.Devel
import Control.Monad (join)
import Data.List (groupBy, intercalate, isPrefixOf, nub)
-
import Data.Maybe (catMaybes)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Language.Haskell.Interpreter hiding (lift, liftIO)
import Language.Haskell.Interpreter.Unsafe
import Language.Haskell.TH
-
import System.Environment (getArgs)
------------------------------------------------------------------------------
@@ -138,7 +137,11 @@ hintSnap opts modules initialization handler = do
loader = join $ formatError `fmap` protectHandlers loadInterpreter
- protectedHintEvaluator 3 loader
+ test prevTime = do
+ now <- getCurrentTime
+ return $ diffUTCTime now prevTime < 4
+
+ protectedHintEvaluator getCurrentTime test loader
------------------------------------------------------------------------------
diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs
b/src/Snap/Extension/Loader/Devel/Evaluator.hs
index a10b179..56c8b24 100644
--- a/src/Snap/Extension/Loader/Devel/Evaluator.hs
+++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs
@@ -14,7 +14,6 @@ import Control.Monad.Trans (liftIO)
import Control.Concurrent (forkIO, myThreadId)
import Control.Concurrent.MVar
-import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import GHC.Prim (Any)
@@ -55,18 +54,21 @@ makeHintInternals init clean exec = HintInternals init'
clean' exec'
-- state until the next execution of the input action. At this time,
-- the cleanup action will be executed.
--
--- There will be at least the passed-in 'NominalDiffTime' delay
--- between the finish of one execution of the action the start of the
--- next. Concurrent calls to the wrapper, and calls within the delay
--- period, end up with the same calculated value returned.
+-- The first two arguments control when recompiles are done. The
+-- first argument is an action that is executed when compilation
+-- starts. The second is a function from the result of the first
+-- action to an action that determines whether the value from the
+-- previous compilation is still good. This abstracts out the
+-- strategy for determining when a cached result is no longer valid.
--
-- If an exception is raised during the processing of the action, it
-- will be thrown to all waiting threads, and for all requests made
-- before the delay time has expired after the exception was raised.
-protectedHintEvaluator :: NominalDiffTime
+protectedHintEvaluator :: IO a
+ -> (a -> IO Bool)
-> IO HintInternals
-> IO (Snap ())
-protectedHintEvaluator minReEval action = do
+protectedHintEvaluator action test getInternals = do
-- The list of requesters waiting for a result. Contains the
-- ThreadId in case of exceptions, and an empty MVar awaiting a
-- successful result.
@@ -80,7 +82,7 @@ protectedHintEvaluator minReEval action = do
-- initialization result, or the exception thrown by the
-- calculation.
--
- -- type: MVar (Maybe (Either SomeException (HintInternals, Any), UTCTime))
+ -- type: MVar (Maybe (Either SomeException (HintInternals, Any), a))
resultContainer <- newMVar Nothing
-- The model used for the above MVars in the returned action is
@@ -88,16 +90,7 @@ protectedHintEvaluator minReEval action = do
-- one of those MVars is emptied, the next action is to fill that
-- same MVar. This makes deadlocking on MVar wait impossible.
return $ do
- existingResult <- liftIO $ readMVar resultContainer
- now <- liftIO getCurrentTime
-
- (hi, any) <- liftIO $ case existingResult of
- Just (res, ts) | diffUTCTime now ts < minReEval ->
- -- There's an existing result, and it's still valid
- case res of
- Right x -> return x
- Left e -> throwIO e
- _ -> do
+ let waitForNewResult = do
-- Need to calculate a new result
tid <- myThreadId
reader <- newEmptyMVar
@@ -119,8 +112,8 @@ protectedHintEvaluator minReEval action = do
previous <- readMVar resultContainer
unblock $ cleanup previous
- -- compile the new action and initialize its state
- hi <- unblock action
+ -- compile the new internals and initialize
+ hi <- unblock getInternals
any <- unblock $ hiInit hi
let a = (hi, any)
@@ -132,8 +125,8 @@ protectedHintEvaluator minReEval action = do
throwIO e
clearAndNotify r f = do
- t <- getCurrentTime
- _ <- swapMVar resultContainer $ Just (r, t)
+ a <- unblock action
+ _ <- swapMVar resultContainer $ Just (r, a)
allReaders <- swapMVar readerContainer []
mapM_ f allReaders
@@ -143,6 +136,20 @@ protectedHintEvaluator minReEval action = do
-- Wait for the evaluation of the action to complete,
-- and return its result.
takeMVar reader
+
+ existingResult <- liftIO $ readMVar resultContainer
+
+ (hi, any) <- liftIO $ case existingResult of
+ Just (res, a) -> do
+ -- There's an existing result. Check for validity
+ valid <- test a
+ case (valid, res) of
+ (True, Right x) -> return x
+ (True, Left e) -> throwIO e
+ (False, _) -> do
+ _ <- swapMVar resultContainer Nothing
+ waitForNewResult
+ Nothing -> waitForNewResult
hiExec hi any
where
cleanup (Just (Right (hi, any), _)) = hiClean hi any
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
