{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} module Happstack.Plugins.Plugins ( rebuild , func , funcTH , withIO , PluginHandle(..) ) where import Control.Applicative ((<$>)) import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_) 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 System.INotify (INotify, WatchDescriptor, Event(..), EventVariety(..), addWatch, removeWatch) import System.FilePath (splitFileName) import Unsafe.Coerce (unsafeCoerce) -- A very unsafe version of Data.Dynamic data Sym toSym :: a -> Sym toSym = unsafeCoerce fromSym :: Sym -> a fromSym = unsafeCoerce -- 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))))) funcTH :: PluginHandle -> Name -> IO (Either Errors a) funcTH objMap name = do let (fp, sym) = nameToFileSym name func objMap fp sym withIO :: PluginHandle -> Name -> (a -> IO ()) -> IO () withIO objMap name use = do r <- funcTH objMap name case r of (Left e) -> putStrLn $ unlines e (Right f) -> use f 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 func :: PluginHandle -> FilePath -> Symbol -> IO (Either Errors a) func ph@(PluginHandle (_inotify, objMap)) fp sym = do om <- readMVar objMap case Map.lookup fp om of Nothing -> do addSymbol ph fp sym rebuild ph fp True func ph fp sym (Just (_, _, Just errs, _)) -> return $ Left errs (Just (_, _, Nothing, symbols)) -> case Map.lookup sym symbols of Nothing -> do addSymbol ph fp sym rebuild ph fp True func ph fp sym (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 p@(PluginHandle (inotify, objMap)) fp forceReload = do putStrLn ("Rebuilding " ++ fp) 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 <- modifyMVar objMap $ \om -> case Map.lookup fp om of 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 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 <- readMVar objMap case Map.lookup fp om of Nothing -> return () (Just (oldWds, _, _, symbols)) -> do mapM_ unloadAll (unloadList symbols) mapM_ (removeWatch inotify) oldWds res <- mapM (load' objFilePath) (Map.assocs symbols) imports <- map (\bn -> addExtension bn ".hs") <$> getImports (dropExtension objFilePath) wds <- observeFiles p fp imports modifyMVar_ objMap $ return . Map.insert fp (wds, [], Nothing, Map.fromList res) where unloadList symbols = nub $ mapMaybe (\(_, eSym) -> case eSym of (Left _) -> Nothing (Right (m,_)) -> Just m) (Map.elems symbols) load' :: FilePath -> (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))) -> IO (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))) load' obj (symbol, (reloader, _)) = do r <- reloader obj case r of (Left errs) -> putStrLn $ unlines errs (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 p@(PluginHandle (_inotify, objMap)) sourceFP sym = do let reloader obj = do putStrLn $ "loading " ++ sym ++ " from " ++ sourceFP ldStatus <- load obj ["."] [] sym case ldStatus of (LoadSuccess m s) -> do putStrLn "Succeed." return (Right (m, toSym s)) (LoadFailure errs) -> do putStrLn "Failed." return (Left errs) symVal = (reloader, Left ["Not loaded yet.."]) modifyMVar_ objMap $ \om -> case Map.lookup sourceFP om of 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 return$ Map.insert sourceFP (wds, deps, errs, symbols') om return ()