diff --git a/System/Plugins/Auto.hs b/System/Plugins/Auto.hs --- a/System/Plugins/Auto.hs +++ b/System/Plugins/Auto.hs @@ -7,6 +7,7 @@ , initPlugins , initPluginsWithConf , defaultPluginConf + , updatePluginConf , withMonadIO , withMonadIO_ , withMonadIOFile @@ -17,7 +18,7 @@ import Language.Haskell.TH.Syntax (Name) import System.Plugins.Auto.LiftName (liftName) import System.Plugins.Auto.Reloader ( PluginHandle, func, funcTH, initPlugins, initPluginsWithConf - , defaultPluginConf, getPluginConf, PluginConf(..)) + , defaultPluginConf, updatePluginConf, PluginConf(..)) -- | Dynamically load the specified symbol pass it as an argument to @@ -39,15 +40,14 @@ Name -- ^ name of the symbol to dynamically load -> a -- ^ the symbol (must be the function refered to by the 'Name' argument) -> PluginHandle -- ^ Handle to the function reloader - -> (PluginConf -> PluginConf) -- ^ introduces variations on the plugin configuration -> ([String] -> m b) -- ^ function called if the symbol is not loaded ( either because the -- last recompilation attempt failed or because it is being -- compiled right now by another thread). -> ([String] -> a -> m b) -- ^ function which uses the loaded result, receives also a -- list of errors in the last recompilation attempt -> m b -withMonadIO_ name _ ph fconf notloaded use = do - (errs,ma) <- liftIO $ funcTH ph name$ getPluginConf ph fconf +withMonadIO_ name _ ph notloaded use = do + (errs,ma) <- liftIO $ funcTH ph name maybe (notloaded errs) (use errs) ma @@ -57,15 +57,14 @@ FilePath -- ^ path to file to load symbol from -> String -- ^ name of the symbol to dynamically load -> PluginHandle -- ^ Handle to the function reloader - -> (PluginConf -> PluginConf) -- ^ introduces variations on the plugin configuration -> ([String] -> m b) -- ^ function called if the symbol is not loaded ( either because the -- last recompilation attempt failed or because it is being -- compiled right now by another thread). -> ([String] -> a -> m b) -- ^ function which uses the loaded result, receives also a -- list of errors in the last recompilation attempt -> m b -withMonadIOFile fp sym ph fconf notloaded use = do - (errs,ma) <- liftIO $ func ph fp sym $ getPluginConf ph fconf +withMonadIOFile fp sym ph notloaded use = do + (errs,ma) <- liftIO$ func ph fp sym maybe (notloaded errs) (use errs) ma diff --git a/System/Plugins/Auto/Reloader.hs b/System/Plugins/Auto/Reloader.hs --- a/System/Plugins/Auto/Reloader.hs +++ b/System/Plugins/Auto/Reloader.hs @@ -8,7 +8,7 @@ , initPlugins , initPluginsWithConf , defaultPluginConf - , getPluginConf + , updatePluginConf ) where import Control.Applicative ((<$>)) @@ -16,6 +16,7 @@ import Control.Concurrent (threadDelay,killThread,ThreadId,forkIO) import Control.Exception (bracketOnError,bracket) import Control.Monad(when) +import Data.IORef (atomicModifyIORef,IORef,newIORef,readIORef) import Data.List (nub) import Data.Maybe (mapMaybe) import qualified Data.Map as Map @@ -57,7 +58,9 @@ { pcGHCArgs = [] , pcWhenCompiling = const$ return () , pcWhenCompiled = const$ const$ return () - , pcWhenReloaded = const$ const$ const$ return () + , pcWhenReloaded = \f s errs -> if null errs then return () + else do putStrLn ("Error when reloading "++f++": "++s) + putStrLn (unlines errs) , pcWhenWatched = const$ return () , pcWhenChanged = const$ return () } @@ -75,7 +78,7 @@ -- | A handle holding the reloader state. data PluginHandle = PluginHandle { phWatcher :: FSWatcher -- Inotify handle - , phConf :: PluginConf + , phConf :: IORef PluginConf , phObjMap :: MVar ( Map FilePath -- source file being observed ( [FSWatchDescriptor] -- watch descriptor of the source file and its dependecies @@ -102,8 +105,19 @@ initPluginsWithConf conf = do inotify <- initFSWatcher objMap <- newMVar Map.empty - return$ PluginHandle inotify conf objMap + rconf <- newIORef conf + return$ PluginHandle inotify rconf objMap + +-- | Updates the configuration used by the plugin handle. +-- +-- Yields the plugin configuration resulting from modifying the +-- plugin handle configuration with the given function. +updatePluginConf :: PluginHandle -> (PluginConf -> PluginConf) -> IO PluginConf +updatePluginConf ph f = atomicModifyIORef (phConf ph)$ \c -> let fc = f c in (fc,fc) + + + newRecompilationState :: IO RecompilationState newRecompilationState = do recompiling <- newMVar False @@ -115,24 +129,17 @@ , rsTimer = timer } --- | Yields the plugin configuration resulting from modifying the --- PluginHandle configuration with the given function. -getPluginConf :: PluginHandle -> (PluginConf -> PluginConf) -> PluginConf -getPluginConf ph fconf = fconf$ phConf ph - - -- | Loads a symbol. It may not return the symbol if it was never -- loaded before and there are compiler errors, or if another -- thread is already loading the symbol. This call should probably -- be changed to be blocking. funcTH :: PluginHandle -- ^ Plugin handle -> Name -- ^ Name of the symbol to load - -> PluginConf -- ^ Arguments to pass to the compiler in case that recompilation is required. -> IO ([String],Maybe a) -- ^ A list of errors if any, and the last succesfully loaded version of the symbol. -funcTH objMap name conf = +funcTH objMap name = do let (fp, sym) = nameToFileSym name - func objMap fp sym conf + func objMap fp sym nameToFileSym :: Name -> (FilePath, Symbol) @@ -147,26 +154,26 @@ -- | Like 'funcTH' but instead of a Name it takes the source file and -- the contained symbol to load. -func :: PluginHandle -> FilePath -> Symbol -> PluginConf -> IO ([String],Maybe a) -func ph fp sym conf = +func :: PluginHandle -> FilePath -> Symbol -> IO ([String],Maybe a) +func ph fp sym = do om <- readMVar$ phObjMap ph case Map.lookup fp om of Nothing -> do bracketOnError - (addSymbol ph fp sym conf) + (addSymbol ph fp sym) (const$ deleteSymbol ph fp sym) - (const$ rebuild ph fp True conf) - func ph fp sym conf + (const$ rebuild ph fp True) + func ph fp sym (Just (_, _, merrs, symbols, _)) -> case Map.lookup sym symbols of Nothing -> case merrs of Nothing -> do bracketOnError - (addSymbol ph fp sym conf) + (addSymbol ph fp sym) (const$ deleteSymbol ph fp sym) - (const$ rebuild ph fp True conf) - func ph fp sym conf + (const$ rebuild ph fp True) + func ph fp sym Just errs -> return (errs,Nothing) Just (_, [], mm) -> @@ -179,12 +186,14 @@ [] -> p++sfx ixs -> take (last ixs) p ++ '.':sfx +getPluginConf :: PluginHandle -> IO PluginConf +getPluginConf = readIORef . phConf + rebuild :: PluginHandle -- ^ list of currently loaded modules/symbols -> FilePath -- ^ source file to compile -> Bool - -> PluginConf -> IO () -rebuild p fp forceReload conf = +rebuild p fp forceReload = do rs <- readMVar (phObjMap p) >>= maybe newRecompilationState (\(_,_,_,_,rs)->return rs) . Map.lookup fp bracket (signalRecompilationStarted rs) @@ -193,6 +202,7 @@ where rebuild' :: RecompilationState -> IO () rebuild' rs = do + conf <- getPluginConf p pcWhenCompiling conf fp makeStatus <- makeAll fp (["-odir",".","-hidir",".","-o",replaceSuffix fp "o"]++pcGHCArgs conf) case makeStatus of @@ -214,7 +224,7 @@ do pcWhenCompiled conf fp [] mapM_ unloadAll (unloadList symbols) mapM_ removeWatch oldWds - res <- mapM (load' objFilePath) (Map.assocs symbols) + res <- mapM (load' conf objFilePath) (Map.assocs symbols) imports <- map (\bn -> addExtension (mnameToPath bn) ".hs") <$> getImports (dropExtension objFilePath) wds <- observeFiles p fp imports conf rs modifyMVar_ (phObjMap p) $ return . Map.insert fp (wds, [], Nothing, Map.fromList res,rs) @@ -222,10 +232,11 @@ unloadList symbols = nub$ mapMaybe (\(_, _, mm) -> fmap fst mm)$ Map.elems symbols - load' :: FilePath + load' :: PluginConf + -> FilePath -> (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Errors, Maybe (Module, Sym))) -> IO (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Errors, Maybe (Module, Sym))) - load' obj (symbol, (reloader, _, _mm)) = + load' conf obj (symbol, (reloader, _, _mm)) = do r <- reloader obj pcWhenReloaded conf obj symbol$ either id (const []) r return (symbol, (reloader, either id (const []) r,either (const Nothing) Just r)) @@ -236,15 +247,16 @@ observeFiles :: PluginHandle -> FilePath -> [FilePath] -> PluginConf -> RecompilationState -> IO [FSWatchDescriptor] observeFiles p fp imports conf rs = - mapM (\depFp -> do let handler = pcWhenChanged conf depFp >> signalRecompilationNeeded rs (rebuild p fp False conf) + mapM (\depFp -> do let handler = pcWhenChanged conf depFp >> signalRecompilationNeeded rs (rebuild p fp False) wd<-addWatch (phWatcher p) depFp handler pcWhenWatched conf depFp >> return wd ) (fp:imports) -addSymbol :: PluginHandle -> FilePath -> Symbol -> PluginConf -> IO () -addSymbol p sourceFP sym conf = - do let reloader obj = +addSymbol :: PluginHandle -> FilePath -> Symbol -> IO () +addSymbol p sourceFP sym = + do conf <- getPluginConf p + let reloader obj = do ldStatus <- load obj ["."] [] sym case ldStatus of (LoadSuccess m s) -> return (Right (m, toSym s)) @@ -258,8 +270,6 @@ (Just (wds, deps, errs, symbols,rs)) -> let symbols' = Map.insert sym symVal symbols in return$ Map.insert sourceFP (wds, deps, errs, symbols',rs) om - - return () deleteSymbol :: PluginHandle -> FilePath -> Symbol -> IO () deleteSymbol ph sourceFP sym = diff --git a/plugins-auto.cabal b/plugins-auto.cabal --- a/plugins-auto.cabal +++ b/plugins-auto.cabal @@ -1,5 +1,5 @@ Name: plugins-auto -Version: 0.0.2 +Version: 0.0.3 Synopsis: Automatic recompilation and reloading of haskell modules. Description: This library provides support for automatically recompiling and reloading modules into your programs when the source code is modified. @@ -24,7 +24,7 @@ > prompt ph = do > putStr "> " > input <- getLine - > $(withMonadIO 'getAnswer) ph id notLoaded$ \errs getAnswer -> + > $(withMonadIO 'getAnswer) ph notLoaded$ \errs getAnswer -> > mapM_ putStrLn errs >> getAnswer input > > notLoaded errs = @@ -49,10 +49,15 @@ source-repository head type: darcs location: http://patch-tag.com/r/facundo/plugins-auto - tag: 0.0.2 +source-repository this + type: darcs + location: http://patch-tag.com/r/facundo/plugins-auto + tag: 0.0.3 + Library exposed-modules: System.Plugins.Auto + other-modules: System.Plugins.Auto.Reloader System.Plugins.Auto.FileSystemWatcher System.Plugins.Auto.LiftName