diff --git a/Happstack/Plugins/Dynamic.hs b/Happstack/Plugins/Dynamic.hs --- a/Happstack/Plugins/Dynamic.hs +++ b/Happstack/Plugins/Dynamic.hs @@ -3,7 +3,7 @@ , initPlugins ) where -import Data.IORef (newIORef) +import Control.Concurrent.MVar (newMVar) import qualified Data.Map as Map import Happstack.Plugins.Plugins (PluginHandle(..)) import System.INotify (initINotify) @@ -12,5 +12,5 @@ initPlugins :: IO PluginHandle initPlugins = do inotify <- initINotify - objMap <- newIORef Map.empty + objMap <- newMVar Map.empty return (PluginHandle (inotify, objMap)) diff --git a/Happstack/Plugins/Plugins.hs b/Happstack/Plugins/Plugins.hs --- a/Happstack/Plugins/Plugins.hs +++ b/Happstack/Plugins/Plugins.hs @@ -8,7 +8,7 @@ ) where import Control.Applicative ((<$>)) -import Data.IORef (IORef, atomicModifyIORef, readIORef) +import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_) import Data.List (nub) import Data.Maybe (mapMaybe) import qualified Data.Map as Map @@ -18,6 +18,7 @@ import System.Plugins.Load (Module, Symbol, LoadStatus(..), getImports, load, unloadAll) import System.Plugins.Make (Errors, MakeStatus(..), MakeCode(..), makeAll) import System.INotify (INotify, WatchDescriptor, Event(..), EventVariety(..), addWatch, removeWatch) +import System.FilePath (splitFileName) import Unsafe.Coerce (unsafeCoerce) -- A very unsafe version of Data.Dynamic @@ -30,10 +31,18 @@ fromSym :: Sym -> a fromSym = unsafeCoerce -newtype PluginHandle = PluginHandle (INotify, IORef (Map FilePath ([WatchDescriptor], [FilePath], Maybe Errors, Map Symbol (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))))) +-- PluginHandle (iNotify, map of watched files) +-- The map of watched files contains: +-- ( WatchDescriptors of the file and its dependencies +-- , dependencies of the file +-- , errors when compiling the file if any +-- , map of symbols defined in the file - this map contains: +-- ( a function which reloads the symbol +-- , the state of the symbol (probably the last call to the function in the first component) +-- ) +-- ) +newtype PluginHandle = PluginHandle (INotify, MVar (Map FilePath ([WatchDescriptor], [FilePath], Maybe Errors, Map Symbol (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))))) -atomicModifyIORef' :: IORef a -> (a -> a) -> IO () -atomicModifyIORef' ref fn = atomicModifyIORef ref (\val -> (fn val, ())) funcTH :: PluginHandle -> Name -> IO (Either Errors a) funcTH objMap name = @@ -59,7 +68,7 @@ func :: PluginHandle -> FilePath -> Symbol -> IO (Either Errors a) func ph@(PluginHandle (_inotify, objMap)) fp sym = - do om <- readIORef objMap + do om <- readMVar objMap case Map.lookup fp om of Nothing -> do addSymbol ph fp sym @@ -75,28 +84,34 @@ (Just (_, Left errs)) -> return $ Left errs (Just (_, Right (_, dynSym))) -> return (Right $ fromSym dynSym) +replaceSuffix :: FilePath -> String -> FilePath +replaceSuffix p sfx = case [ i | (i,'.') <- zip [0..] p ] of + [] -> p++sfx + ixs -> take (last ixs) p ++ '.':sfx + rebuild :: PluginHandle -- ^ list of currently loaded modules/symbols -> FilePath -- ^ source file to compile -> Bool -> IO () -rebuild (PluginHandle (inotify, objMap)) fp forceReload = +rebuild p@(PluginHandle (inotify, objMap)) fp forceReload = do putStrLn ("Rebuilding " ++ fp) - makeStatus <- makeAll fp [] -- FIXME: allow user to specify additional flags, such as -O2 + makeStatus <- makeAll fp ["-odir",".","-hidir",".","-o",replaceSuffix fp "o"] -- FIXME: allow user to specify additional flags, such as -O2 case makeStatus of (MakeFailure errs) -> - do unload <- atomicModifyIORef objMap $ \om -> + do unload <- modifyMVar objMap $ \om -> case Map.lookup fp om of - Nothing -> (Map.insert fp ([], [], Just errs, Map.empty) om, []) + Nothing -> do wds <- observeFiles p fp [] + return (Map.insert fp (wds, [], Just errs, Map.empty) om, []) (Just (wds, deps, _, symbols)) -> let symbols' = Map.map (\(loader,_) -> (loader, Left errs)) symbols -- propogate error to all symbols - in (Map.insert fp (wds, deps, Just errs, symbols') om, unloadList symbols) + in return (Map.insert fp (wds, deps, Just errs, symbols') om, unloadList symbols) mapM_ unloadAll unload putStrLn $ unlines errs (MakeSuccess NotReq _objFilePath) | not forceReload -> do putStrLn "skipped reload." return () (MakeSuccess _makeCode objFilePath) -> - do om <- readIORef objMap + do om <- readMVar objMap case Map.lookup fp om of Nothing -> return () (Just (oldWds, _, _, symbols)) -> @@ -104,12 +119,8 @@ mapM_ (removeWatch inotify) oldWds res <- mapM (load' objFilePath) (Map.assocs symbols) imports <- map (\bn -> addExtension bn ".hs") <$> getImports (dropExtension objFilePath) - wds <- mapM (\depFp -> putStrLn ("Adding watch for: " ++ depFp) >> addWatch inotify [Modify, Move, Delete] depFp - (\e -> do putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) - case e of - Ignored -> return () - _ -> rebuild (PluginHandle (inotify, objMap)) fp False)) (fp:imports) - atomicModifyIORef' objMap $ Map.insert fp (wds, [], Nothing, Map.fromList res) + wds <- observeFiles p fp imports + modifyMVar_ objMap $ return . Map.insert fp (wds, [], Nothing, Map.fromList res) where unloadList symbols = nub $ mapMaybe (\(_, eSym) -> @@ -127,8 +138,24 @@ (Right _) -> return () return (symbol, (reloader, r)) + +observeFiles :: PluginHandle -> FilePath -> [FilePath] -> IO [WatchDescriptor] +observeFiles p@(PluginHandle (inotify,_objMap)) fp imports = + mapM (\depFp -> do putStrLn ("Adding watch for: " ++ depFp) + let (d,f) = splitFileName depFp + addWatch inotify [Modify, Move, Delete] d $ \e -> + do putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) + case e of + Ignored -> return () + Deleted { filePath = f' } | f==f' -> rebuild p fp False + MovedIn { filePath = f' } | f==f' -> rebuild p fp False + Modified { maybeFilePath = Just f' } | f==f' -> rebuild p fp False + _ -> return () + ) (fp:imports) + + addSymbol :: PluginHandle -> FilePath -> Symbol -> IO () -addSymbol (PluginHandle (_inotify, objMap)) sourceFP sym = +addSymbol p@(PluginHandle (_inotify, objMap)) sourceFP sym = do let reloader obj = do putStrLn $ "loading " ++ sym ++ " from " ++ sourceFP ldStatus <- load obj ["."] [] sym @@ -140,12 +167,13 @@ do putStrLn "Failed." return (Left errs) symVal = (reloader, Left ["Not loaded yet.."]) - atomicModifyIORef' objMap $ \om -> + modifyMVar_ objMap $ \om -> case Map.lookup sourceFP om of - Nothing -> Map.insert sourceFP ([], [], Nothing, Map.singleton sym symVal) om + Nothing -> do wds <- observeFiles p sourceFP [] + return$ Map.insert sourceFP (wds, [], Nothing, Map.singleton sym symVal) om (Just (wds, deps, errs, symbols)) -> let symbols' = Map.insert sym symVal symbols - in Map.insert sourceFP (wds, deps, errs, symbols') om + in return$ Map.insert sourceFP (wds, deps, errs, symbols') om return () diff --git a/happstack-plugins.cabal b/happstack-plugins.cabal --- a/happstack-plugins.cabal +++ b/happstack-plugins.cabal @@ -1,5 +1,5 @@ Name: happstack-plugins -Version: 6.0.1 +Version: 6.0.2 Synopsis: The haskell application server stack + reload Description: This library provides support for automatically recompiling and reloading modules into a running server. License: BSD3