{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-}
module Happstack.Plugins.Plugins
( rebuild
, func
, funcTH
, withIO
, PluginHandle(..)
, initPersistentINotify
) where
import Control.Applicative ((<$>))
import Control.Concurrent.MVar (MVar,readMVar,modifyMVar,modifyMVar_,newMVar)
import Control.Exception (bracketOnError)
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, initINotify)
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
newtype PluginHandle = PluginHandle
( PersistentINotify -- Inotify handle
, MVar
( Map FilePath -- source file being observed
( [WatchDescriptorP] -- 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
, Either Errors (Module, Sym)) -- the state of the symbol (probably the result of the last call to the function in the first component)
)
)
)
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 bracketOnError
(addSymbol ph fp sym)
(const$ deleteSymbol ph fp sym)
(const$ 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 bracketOnError
(addSymbol ph fp sym)
(const$ deleteSymbol ph fp sym)
(const$ 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_ removeWatchP oldWds
res <- mapM (load' objFilePath) (Map.assocs symbols)
imports <- map (\bn -> addExtension (mnameToPath 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))
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] -> IO [WatchDescriptorP]
observeFiles p@(PluginHandle (inotify,_objMap)) fp imports =
mapM (\depFp -> do putStrLn ("Adding watch for: " ++ depFp)
let handler e = putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) >> rebuild p fp False
addWatchP inotify depFp handler
) (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 ()
deleteSymbol :: PluginHandle -> FilePath -> Symbol -> IO ()
deleteSymbol (PluginHandle (_inotify, objMap)) sourceFP sym =
modifyMVar_ objMap $ \om ->
case Map.lookup sourceFP om of
Nothing -> return om
(Just (wds, deps, errs, symbols)) ->
let symbols' = Map.delete sym symbols
in return$ Map.insert sourceFP (wds, deps, errs, symbols') om
-- Keeps watching a file even after it has been deleted and created again.
--
-- It does so by observing the folder which contains the file. When no files
-- are observed in a given folder, the folder stops being observed.
data PersistentINotify = PersistentINotify
INotify -- INotify handle
(MVar
(Map FilePath -- Folder containing the file
( WatchDescriptor -- Watch descriptor of the folder
, Map String -- File being observed
(Event -> IO ()) -- Handler to run on file events
)
)
)
data WatchDescriptorP = WatchDescriptorP PersistentINotify FilePath
initPersistentINotify :: IO PersistentINotify
initPersistentINotify = do
iN <- initINotify
fmvar <- newMVar Map.empty
return$ PersistentINotify iN fmvar
-- Replacement for splitFileName which returns "." instead of an empty folder.
splitFileName' :: FilePath -> (FilePath,String)
splitFileName' fp =
let (d,f) = splitFileName fp
in (if null d then "." else d,f)
addWatchP :: PersistentINotify -> FilePath -> (Event -> IO ()) -> IO WatchDescriptorP
addWatchP piN@(PersistentINotify iN fmvar) fp hdl =
let (d,f) = splitFileName' fp
in modifyMVar fmvar$ \fm ->
case Map.lookup d fm of
Nothing -> do
wd <- addWatch iN [Modify, Move, Delete] d $ \e -> do
case e of
Ignored -> return ()
Deleted { filePath = f' } -> callHandler e d f'
MovedIn { filePath = f' } -> callHandler e d f'
Modified { maybeFilePath = Just f' } -> callHandler e d f'
_ -> return ()
return ( Map.insert d (wd,Map.singleton f hdl) fm
, WatchDescriptorP piN fp
)
Just (wd,ffm) -> return ( Map.insert d (wd,Map.insert f hdl ffm) fm
, WatchDescriptorP piN fp
)
where
callHandler e d f = do
fm <- readMVar fmvar
case Map.lookup d fm of
Nothing -> return ()
Just (_,ffm) -> case Map.lookup f ffm of
Nothing -> return ()
Just mhdl -> mhdl e
removeWatchP :: WatchDescriptorP -> IO ()
removeWatchP (WatchDescriptorP (PersistentINotify iN fmvar) fp) =
let (d,f) = splitFileName' fp
in modifyMVar_ fmvar$ \fm ->
case Map.lookup d fm of
Nothing -> error$ "removeWatchP: invalid handle for file "++fp
Just (wd,ffm) -> let ffm' = Map.delete f ffm
in if Map.null ffm' then removeWatch wd >> return (Map.delete d fm)
else return (Map.insert d (wd,ffm') fm)