happstack-plugins-6.0.2: Happstack/Plugins/Plugins.hs
{-# 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 ()