snap-loader-dynamic 0.10 → 0.10.0.1
raw patch · 4 files changed
+70/−45 lines, 4 filesdep ~hintdep ~snap-coredep ~template-haskell
Dependency ranges changed: hint, snap-core, template-haskell, unix
Files
- snap-loader-dynamic.cabal +5/−5
- src/Snap/Loader/Dynamic.hs +47/−21
- src/Snap/Loader/Dynamic/Evaluator.hs +10/−9
- src/Snap/Loader/Dynamic/Signal.hs +8/−10
snap-loader-dynamic.cabal view
@@ -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
src/Snap/Loader/Dynamic.hs view
@@ -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
src/Snap/Loader/Dynamic/Evaluator.hs view
@@ -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
src/Snap/Loader/Dynamic/Signal.hs view
@@ -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 ------------------------------------------------------------------------------