{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} -- | This module implements recompilation and reloading of symbols. module System.Plugins.Auto.Reloader ( funcTH , func , PluginHandle , PluginConf(..) , initPlugins , initPluginsWithConf , defaultPluginConf , getPluginConf ) where import Control.Applicative ((<$>)) import Control.Concurrent.MVar (MVar,readMVar,modifyMVar_,newMVar,modifyMVar) import Control.Concurrent (threadDelay,killThread,ThreadId,forkIO) import Control.Exception (bracketOnError,bracket) import Control.Monad(when) import Data.List (nub) import Data.Maybe (mapMaybe) import qualified Data.Map as Map import Data.Map (Map) import Language.Haskell.TH.Syntax (Name(Name),NameFlavour(NameG), occString, modString) import System.FilePath (addExtension, dropExtension) import System.Plugins.Load (Module, Symbol, LoadStatus(..), getImports, load, unloadAll) import System.Plugins.Make (Errors, MakeStatus(..), MakeCode(..), makeAll) import Unsafe.Coerce (unsafeCoerce) import System.Plugins.Auto.FileSystemWatcher -- A very unsafe version of Data.Dynamic data Sym toSym :: a -> Sym toSym = unsafeCoerce fromSym :: Sym -> a fromSym = unsafeCoerce -- | Configuration options for recompiling plugins. So far we store here event callbacks and ghc arguments. data PluginConf = PluginConf { pcGHCArgs :: [String] -- ^Arguments to ghc , pcWhenCompiling :: FilePath -> IO () -- ^ Called when compilation is about to start. Takes the path of the file to compile. , pcWhenCompiled :: FilePath -> [String] -> IO () -- ^ Called after compilation finished. -- Takes the path of the compiled file and the compilation errors if any. , pcWhenReloaded :: FilePath -> String -> [String] -> IO () -- ^ Called after reloading of the symbol finished. -- Takes the path of the object file, the symbol name and the list -- of errors if any. , pcWhenWatched :: FilePath -> IO () -- ^ Called when a file is registered for watching. , pcWhenChanged :: FilePath -> IO () -- ^ Called when a watched file is modified. } -- | Contains no arguments for GHC, and noop callbacks. defaultPluginConf :: PluginConf defaultPluginConf = PluginConf { pcGHCArgs = [] , pcWhenCompiling = const$ return () , pcWhenCompiled = const$ const$ return () , pcWhenReloaded = const$ const$ const$ return () , pcWhenWatched = const$ return () , pcWhenChanged = const$ return () } -- | Represents the state of the recompilation for a source file. data RecompilationState = RecompilationState { rsRecompiling :: MVar Bool -- ^ Is recompilation in progress? , rsRecompilationNeeded :: MVar Bool -- ^ Is recompilation needed? , rsTimer :: Timer -- ^ The timer is used to delay recompilation a fraction of a second -- so we can recompile in one pass changes in multiple source code -- files. } -- | A handle holding the reloader state. data PluginHandle = PluginHandle { phWatcher :: FSWatcher -- Inotify handle , phConf :: PluginConf , phObjMap :: MVar ( Map FilePath -- source file being observed ( [FSWatchDescriptor] -- watch descriptor of the source file and its dependecies , [FilePath] -- depedencies of the source file , Maybe Errors -- errors when compiling the file if any , Map Symbol -- symbol defined in the source file ( FilePath -> IO (Either Errors (Module, Sym)) -- function for reloading the symbol , Errors -- error from last recompilation attempt if any , Maybe (Module, Sym) -- last succesfully loaded symbol ) , RecompilationState ) ) } -- | Initializes the plugin system and return a 'PluginHandle' -- using the default plugin configuration 'defaultPluginConf'. initPlugins :: IO PluginHandle initPlugins = initPluginsWithConf defaultPluginConf -- | Initializes the plugin system and return a 'PluginHandle'. initPluginsWithConf :: PluginConf -> IO PluginHandle initPluginsWithConf conf = do inotify <- initFSWatcher objMap <- newMVar Map.empty return$ PluginHandle inotify conf objMap newRecompilationState :: IO RecompilationState newRecompilationState = do recompiling <- newMVar False recompilationNeeded <- newMVar False timer <- newTimer return RecompilationState { rsRecompiling = recompiling , rsRecompilationNeeded = recompilationNeeded , 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 = do let (fp, sym) = nameToFileSym name func objMap fp sym conf nameToFileSym :: Name -> (FilePath, Symbol) nameToFileSym (Name occName (NameG _ _ mn)) = let dotToSlash '.' = '/' dotToSlash c = c fp = (map dotToSlash (modString mn)) ++ ".hs" sym = occString occName in (fp, sym) nameToFileSym n = error $ "nameToFileSym failed because Name was not the right kind. " ++ show n -- | 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 = do om <- readMVar$ phObjMap ph case Map.lookup fp om of Nothing -> do bracketOnError (addSymbol ph fp sym conf) (const$ deleteSymbol ph fp sym) (const$ rebuild ph fp True conf) func ph fp sym conf (Just (_, _, merrs, symbols, _)) -> case Map.lookup sym symbols of Nothing -> case merrs of Nothing -> do bracketOnError (addSymbol ph fp sym conf) (const$ deleteSymbol ph fp sym) (const$ rebuild ph fp True conf) func ph fp sym conf Just errs -> return (errs,Nothing) Just (_, [], mm) -> return (maybe [] id merrs, fmap (fromSym . snd) mm) Just (_, errs, mm) -> return (errs,fmap (fromSym . snd) mm) 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 -> PluginConf -> IO () rebuild p fp forceReload conf = do rs <- readMVar (phObjMap p) >>= maybe newRecompilationState (\(_,_,_,_,rs)->return rs) . Map.lookup fp bracket (signalRecompilationStarted rs) (\compile -> when compile$ signalRecompilationFinished rs (rebuild' rs)) (\compile -> when compile$ rebuild' rs) where rebuild' :: RecompilationState -> IO () rebuild' rs = do pcWhenCompiling conf fp makeStatus <- makeAll fp (["-odir",".","-hidir",".","-o",replaceSuffix fp "o"]++pcGHCArgs conf) case makeStatus of (MakeFailure errs) -> do modifyMVar_ (phObjMap p) $ \om -> case Map.lookup fp om of Nothing -> do wds <- observeFiles p fp [] conf rs return$ Map.insert fp (wds, [], Just errs, Map.empty, rs) om Just (wds, deps, _, symbols,_) -> let symbols' = Map.map (\(loader,_,mm) -> (loader,errs,mm)) symbols -- propogate error to all symbols in return$ Map.insert fp (wds, deps, Just errs, symbols',rs) om pcWhenCompiled conf fp errs (MakeSuccess NotReq _objFilePath) | not forceReload -> pcWhenCompiled conf fp [] (MakeSuccess _makeCode objFilePath) -> do om <- readMVar$ phObjMap p case Map.lookup fp om of Nothing -> return () Just (oldWds, _, _, symbols,_) -> do pcWhenCompiled conf fp [] mapM_ unloadAll (unloadList symbols) mapM_ removeWatch oldWds res <- mapM (load' 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) unloadList symbols = nub$ mapMaybe (\(_, _, mm) -> fmap fst mm)$ Map.elems symbols load' :: 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)) = do r <- reloader obj pcWhenReloaded conf obj symbol$ either id (const []) r return (symbol, (reloader, either id (const []) r,either (const Nothing) Just r)) mnameToPath :: FilePath -> FilePath mnameToPath = replace '.' '/' where replace x y = foldr (\a r -> if x==a then y:r else a:r) [] 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) 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 = do ldStatus <- load obj ["."] [] sym case ldStatus of (LoadSuccess m s) -> return (Right (m, toSym s)) (LoadFailure errs) -> return (Left errs) symVal = (reloader, [], Nothing) modifyMVar_ (phObjMap p) $ \om -> case Map.lookup sourceFP om of Nothing -> do rs <- newRecompilationState wds <- observeFiles p sourceFP [] conf rs return$ Map.insert sourceFP (wds, [], Nothing, Map.singleton sym symVal,rs) om (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 = modifyMVar_ (phObjMap ph) $ \om -> case Map.lookup sourceFP om of Nothing -> return om Just (wds, deps, errs, symbols,rs) -> let symbols' = Map.delete sym symbols in return$ Map.insert sourceFP (wds, deps, errs, symbols',rs) om -------------------------------- -- Recompilation handling -------------------------------- -- | Indicates that recompilation is needed. If compilation is in progress -- recompilation will be done afterwards, otherwise recompilation starts -- in a few milliseconds after the call. signalRecompilationNeeded :: RecompilationState -- ^ Internal state for synchronizing recompilation requests -> IO () -- ^ Command which starts recompilation -> IO () signalRecompilationNeeded rs recomp = do modifyMVar_ (rsRecompilationNeeded rs)$ const$ return True mvarIf (rsRecompiling rs) (return ()) (testRecompilation rs recomp) -- | Indicates that recompilation is starting. The returned boolean indicates whether -- there is any other attempt for recompilation in progress. signalRecompilationStarted :: RecompilationState -> IO Bool signalRecompilationStarted rs = do modifyMVar (rsRecompiling rs)$ \b -> do when (not b)$ modifyMVar_ (rsRecompilationNeeded rs)$ const$ return False return (True,not b) -- | Indicates that recompilation has stopped. -- It test whether recompilation is needed, and if needed it starts it again. signalRecompilationFinished :: RecompilationState -- ^ Internal state for synchronizing recompilation requests -> IO () -- ^ Command which starts recompilation -> IO () signalRecompilationFinished rs recomp = do modifyMVar_ (rsRecompiling rs)$ const$ return False testRecompilation rs recomp -- | Fires the recompilation command after a small timeout if recompilation is needed -- after the timeout expired. The timeout allows to delay recompilation if new requests -- for recompilation arrive before the recompilation starts. testRecompilation :: RecompilationState -> IO () -> IO () testRecompilation rs recomp = setTimer (rsTimer rs) (400*1000)$ mvarIf (rsRecompilationNeeded rs) recomp (return ()) mvarIf :: MVar Bool -> IO a -> IO a -> IO a mvarIf mb th els = readMVar mb >>= \b -> if b then th else els -------------------------------- -- Timer data type -------------------------------- newtype Timer = Timer (MVar (Maybe ThreadId)) newTimer :: IO Timer newTimer = fmap Timer$ newMVar Nothing -- Register an action to perform after a timeout. -- Cancels previous timer setting. setTimer :: Timer -> Int -> IO () -> IO () setTimer (Timer mmtid) delay action = modifyMVar_ mmtid$ \mtid -> do maybe (return ()) killThread mtid fmap Just$ forkIO$ threadDelay delay >> modifyMVar_ mmtid (const (return Nothing)) >> action