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 9e0daeaf7989fc3dd72f5d83b224ad0b360789ca (commit)
from 7e10297343f357e49265d286d13d38f21a1dc694 (commit)
Summary of changes:
snap.cabal | 1 -
src/Snap/Extension.hs | 2 +-
src/Snap/Extension/Loader/Devel/Evaluator.hs | 79 ++++++++++++-------------
3 files changed, 39 insertions(+), 43 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 9e0daeaf7989fc3dd72f5d83b224ad0b360789ca
Author: Carl Howells <[email protected]>
Date: Thu Dec 23 12:48:16 2010 -0800
Replace unsafeCoerce/Any combination with an existential data type
diff --git a/snap.cabal b/snap.cabal
index 64abbbc..cfaf413 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -51,7 +51,6 @@ Library
directory >= 1.0 && < 1.2,
enumerator == 0.4.*,
filepath >= 1.1 && <1.3,
- ghc-prim,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
snap-core == 0.3.*,
heist >= 0.4 && < 0.5,
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
index d51776c..1f5f8a4 100644
--- a/src/Snap/Extension.hs
+++ b/src/Snap/Extension.hs
@@ -415,7 +415,7 @@ getHintInternals :: Initializer s
-> SnapExtend s ()
-- ^ An action in your application's monad.
-> HintInternals
-getHintInternals i se = makeHintInternals runInit getCleanup getAction
+getHintInternals i se = HintInternals runInit getCleanup getAction
where
runInit = runInitializer True i se
getAction (action, _, _) = action
diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs
b/src/Snap/Extension/Loader/Devel/Evaluator.hs
index 0287434..267ae8c 100644
--- a/src/Snap/Extension/Loader/Devel/Evaluator.hs
+++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Extension.Loader.Devel.Evaluator
- ( HintInternals
- , makeHintInternals
+ ( HintInternals(..)
, protectedHintEvaluator
) where
@@ -11,41 +12,30 @@ import Control.Exception
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
-import Control.Concurrent (forkIO, myThreadId)
+import Control.Concurrent (ThreadId, forkIO, myThreadId)
import Control.Concurrent.MVar
import Data.Typeable (Typeable)
-import GHC.Prim (Any)
-
import Prelude hiding (catch, init, any)
import Snap.Types (Snap)
-import Unsafe.Coerce (unsafeCoerce)
-
------------------------------------------------------------------------------
-- | A monomorphic type to hide polymorphism. This allows Hint to
--- load the action, since it requires loading a monomorphic type. The
--- constructor for this is not exposed because its internals are
--- incredibly far from type safe.
-data HintInternals = HintInternals
- { hiInit :: IO Any
- , hiClean :: Any -> IO ()
- , hiExec :: Any -> Snap ()
- } deriving Typeable
+-- load the action, since it requires loading a monomorphic type.
+data HintInternals = forall a. HintInternals (IO a) (a -> IO ()) (a -> Snap ())
+ deriving Typeable
------------------------------------------------------------------------------
--- | A smart constructor to hide the incredibly type unsafe internals
--- of HintInternals behind a type safe smart constructor.
-makeHintInternals :: IO a -> (a -> IO ()) -> (a -> Snap ()) -> HintInternals
-makeHintInternals init clean exec = HintInternals init' clean' exec'
- where
- init' = fmap unsafeCoerce init
- clean' = clean . unsafeCoerce
- exec' = exec . unsafeCoerce
+-- | 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)
------------------------------------------------------------------------------
@@ -64,7 +54,8 @@ makeHintInternals init clean exec = HintInternals init'
clean' exec'
-- 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 :: IO a
+protectedHintEvaluator :: forall a.
+ IO a
-> (a -> IO Bool)
-> IO HintInternals
-> IO (Snap ())
@@ -72,25 +63,30 @@ protectedHintEvaluator start 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.
- --
- -- type: MVar [(ThreadId, MVar (Snap ()))]
- readerContainer <- newMVar []
+
+ let newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])
+ newReaderContainer = newMVar []
+
+ newResultContainer :: IO (MVar (Maybe (Either SomeException
+ (IO (), Snap ()), a)))
+ newResultContainer = newMVar Nothing
+
+ readerContainer <- newReaderContainer
-- Contains the previous result and initialization value, and the
-- time it was stored, if a previous result has been computed.
-- The result stored is either the actual result and
-- initialization result, or the exception thrown by the
-- calculation.
- --
- -- type: MVar (Maybe (Either SomeException (HintInternals, Any), a))
- resultContainer <- newMVar Nothing
+ resultContainer <- newResultContainer
-- The model used for the above MVars in the returned action is
-- "keep them full, unless updating them." In every case, when
-- one of those MVars is emptied, the next action is to fill that
-- same MVar. This makes deadlocking on MVar wait impossible.
return $ do
- let waitForNewResult = do
+ let waitForNewResult :: IO (Snap ())
+ waitForNewResult = do
-- Need to calculate a new result
tid <- myThreadId
reader <- newEmptyMVar
@@ -114,10 +110,11 @@ protectedHintEvaluator start test getInternals = do
-- compile the new internals and initialize
hi <- unblock getInternals
- any <- unblock $ hiInit hi
+ res <- unblock $ initInternals hi
+
+ let a = snd res
- let a = (hi, any)
- clearAndNotify (Right a) (flip putMVar a . snd)
+ clearAndNotify (Right res) (flip putMVar a . snd)
killWaiting :: SomeException -> IO ()
killWaiting e = block $ do
@@ -139,18 +136,18 @@ protectedHintEvaluator start test getInternals = do
existingResult <- liftIO $ readMVar resultContainer
- (hi, any) <- liftIO $ case existingResult of
+ getResult <- 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
+ (True, Right (_, x)) -> return x
+ (True, Left e) -> throwIO e
+ (False, _) -> do
_ <- swapMVar resultContainer Nothing
waitForNewResult
Nothing -> waitForNewResult
- hiExec hi any
+ getResult
where
- cleanup (Just (Right (hi, any), _)) = hiClean hi any
- cleanup _ = return ()
+ cleanup (Just (Right (clean, _), _)) = clean
+ cleanup _ = return ()
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
