diff --git a/snap-loader-dynamic.cabal b/snap-loader-dynamic.cabal --- a/snap-loader-dynamic.cabal +++ b/snap-loader-dynamic.cabal @@ -1,5 +1,5 @@ name: snap-loader-dynamic -version: 0.10 +version: 0.10.0.1 synopsis: Snap: A Haskell Web Framework: dynamic loader description: Snap Framework dynamic loader license: BSD3 @@ -32,13 +32,13 @@ base >= 4 && < 5, directory-tree >= 0.10 && < 0.12, mtl > 2.0 && < 2.2, - snap-core >= 0.9 && < 0.11, + snap-core >= 0.9 && < 0.10, time >= 1.1 && < 1.5, - template-haskell >= 2.2 && < 2.9 + template-haskell >= 2.2 && < 2.10 if impl(ghc >= 7.2.0) build-depends: - hint >= 0.3.3.1 && < 0.4 + hint >= 0.3.3.1 && < 0.5 else build-depends: hint >= 0.3.3.1 && < 0.3.3.5 @@ -53,7 +53,7 @@ if !os(windows) build-depends: - unix >= 2.2.0.0 && < 2.7 + unix >= 2.2.0.0 && < 2.8 extensions: CPP diff --git a/src/Snap/Loader/Dynamic.hs b/src/Snap/Loader/Dynamic.hs --- a/src/Snap/Loader/Dynamic.hs +++ b/src/Snap/Loader/Dynamic.hs @@ -11,13 +11,14 @@ ) where ------------------------------------------------------------------------------ -import Control.Monad (liftM2) +import Control.Concurrent +import Control.Monad (liftM2, forever) import Data.Char (isAlphaNum) import Data.List import Data.Maybe (maybeToList) import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Typeable -import Language.Haskell.Interpreter hiding (lift, liftIO, typeOf) +import Language.Haskell.Interpreter hiding (lift, typeOf) import Language.Haskell.Interpreter.Unsafe import Language.Haskell.TH import System.Environment (getArgs) @@ -83,7 +84,7 @@ getHintOpts args = removeBad opts where -------------------------------------------------------------------------- - bad = ["-threaded", "-O", "-main-is", "-o", "--make"] + bad = ["-threaded", "-O", "-main-is", "-o", "--make", "-static"] -------------------------------------------------------------------------- removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) @@ -92,9 +93,7 @@ hideAll = filter (== "-hide-all-packages") args -------------------------------------------------------------------------- - srcOpts = filter (\x -> "-i" `isPrefixOf` x - && not ("-idist" `isPrefixOf` x)) - args + srcOpts = filter (\x -> "-i" `isPrefixOf` x) args -------------------------------------------------------------------------- toCopy = filter (not . isSuffixOf ".hs") $ @@ -142,14 +141,30 @@ -> a -- ^ The value to apply the loaded function to -> IO (Snap (), IO ()) -hintSnap opts modules srcPaths action value = - protectedHintEvaluator initialize test loader - +hintSnap opts modules srcPaths action value = do + load <- runInterpreterThread + protectedHintEvaluator getCurrentState testState load where -------------------------------------------------------------------------- witness x = undefined $ x `asTypeOf` value :: HintLoadable +#if MIN_VERSION_base(4,7,0) -------------------------------------------------------------------------- + witnessModules = filter (`notElem` inPrelude) . map dropInternal . + map tyConModule . tyCons . typeOf $ witness + + -------------------------------------------------------------------------- + inPrelude = ["GHC.Prim", "GHC.Types", "GHC.Tuple"] + + -------------------------------------------------------------------------- + tyCons x = let (c, rs) = splitTyConApp x in c : concatMap tyCons rs + + -------------------------------------------------------------------------- + dropInternal s = case stripPrefix "Snap.Internal." s of + Nothing -> s + Just x -> "Snap." ++ x +#else + -------------------------------------------------------------------------- -- This is somewhat fragile, and probably can be cleaned up with a future -- version of Typeable. For the moment, and backwards-compatibility, this -- is the approach being taken. @@ -159,30 +174,41 @@ -------------------------------------------------------------------------- typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.' +#endif -------------------------------------------------------------------------- - interpreter = do - loadModules . nub $ modules - setImports . nub $ "Prelude" : "Snap.Core" : witnessModules ++ modules + runInterpreterThread = do + input <- newEmptyMVar + output <- newEmptyMVar + + forkIO . forever $ do + restore <- protectHandlers + err <- unsafeRunInterpreterWithArgs opts $ do + liftIO $ restore + forever $ do + liftIO $ takeMVar input - f <- interpret action witness - return $ f value + loadModules . nub $ modules + setImports . nub $ "Prelude" : "Snap.Core" : + witnessModules ++ modules + f <- interpret action witness - -------------------------------------------------------------------------- - loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter + liftIO . putMVar output $ f value + reset + putMVar output $ formatOnError err + + return $ putMVar input () >> takeMVar output + -------------------------------------------------------------------------- formatOnError (Left err) = error $ format err formatOnError (Right a) = a -------------------------------------------------------------------------- - loader = formatOnError `fmap` protectHandlers loadInterpreter - - -------------------------------------------------------------------------- - initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths + getCurrentState = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths -------------------------------------------------------------------------- - test (prevTime, ts) = do + testState (prevTime, ts) = do now <- getCurrentTime if diffUTCTime now prevTime < 3 then return True diff --git a/src/Snap/Loader/Dynamic/Evaluator.hs b/src/Snap/Loader/Dynamic/Evaluator.hs --- a/src/Snap/Loader/Dynamic/Evaluator.hs +++ b/src/Snap/Loader/Dynamic/Evaluator.hs @@ -75,27 +75,28 @@ -- previous state, if there was any, and then begin -- evaluation of the new code and state. when (null readers) $ do - let runAndFill = block $ do + let runAndFill = mask $ \unmask -> do -- run the cleanup action previous <- readMVar resultContainer - unblock $ cleanup previous + unmask $ cleanup previous -- compile the new internals and initialize - stateInitializer <- unblock getInternals - res <- unblock stateInitializer + stateInitializer <- unmask getInternals + res <- unmask stateInitializer let a = fst res - clearAndNotify (Right res) + clearAndNotify unmask (Right res) (flip putMVar a . snd) killWaiting :: SomeException -> IO () - killWaiting e = block $ do - clearAndNotify (Left e) (flip throwTo e . fst) + killWaiting e = mask $ \unmask -> do + clearAndNotify unmask (Left e) + (flip throwTo e . fst) throwIO e - clearAndNotify r f = do - a <- unblock start + clearAndNotify unmask r f = do + a <- unmask start _ <- swapMVar resultContainer $ Just (r, a) allReaders <- swapMVar readerContainer [] mapM_ f allReaders diff --git a/src/Snap/Loader/Dynamic/Signal.hs b/src/Snap/Loader/Dynamic/Signal.hs --- a/src/Snap/Loader/Dynamic/Signal.hs +++ b/src/Snap/Loader/Dynamic/Signal.hs @@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} module Snap.Loader.Dynamic.Signal (protectHandlers) where ------------------------------------------------------------------------------- -import Control.Exception (bracket) - - #ifdef mingw32_HOST_OS ------------- @@ -16,8 +12,8 @@ saveHandlers :: IO C.Handler saveHandlers = C.installHandler Ignore -restoreHandlers :: C.Handler -> IO C.Handler -restoreHandlers = C.installHandler +restoreHandlers :: C.Handler -> IO () +restoreHandlers = C.installHandler >> return () ------------------------------------------------------------------------------ @@ -42,8 +38,8 @@ saveHandlers :: IO [S.Handler] saveHandlers = mapM (helper S.Ignore) signals -restoreHandlers :: [S.Handler] -> IO [S.Handler] -restoreHandlers h = sequence $ zipWith helper h signals +restoreHandlers :: [S.Handler] -> IO () +restoreHandlers h = sequence_ $ zipWith helper h signals ------------------------------------------------------------------------------ #endif @@ -52,6 +48,8 @@ -- both -- ---------- ------------------------------------------------------------------------------ -protectHandlers :: IO a -> IO a -protectHandlers a = bracket saveHandlers restoreHandlers $ const a +protectHandlers :: IO (IO ()) +protectHandlers = do + h <- saveHandlers + return $ restoreHandlers h ------------------------------------------------------------------------------