{-# LANGUAGE CPP #-}
module Xmobar.App.Compile(recompile, xmessage) where
import Control.Monad.IO.Class
import Control.Monad.Fix (fix)
import Control.Exception.Extensible (try, bracket, SomeException(..))
import qualified Control.Exception.Extensible as E
import Control.Monad (filterM, when)
import Data.List ((\\))
import Data.Maybe (isJust)
import System.FilePath((</>), takeExtension)
import System.IO
import System.Directory
import System.Process
import System.Exit
import System.Posix.Process(executeFile, forkProcess, getAnyProcessStatus)
import System.Posix.Types(ProcessID)
import System.Posix.Signals
isExecutable :: FilePath -> IO Bool
isExecutable f =
E.catch (executable <$> getPermissions f) (\(SomeException _) -> return False)
checkBuildScript :: Bool -> FilePath -> IO Bool
checkBuildScript verb buildscript = do
exists <- doesFileExist buildscript
if exists
then do
isExe <- isExecutable buildscript
if isExe
then do
trace verb $ "Xmobar will use build script at "
++ show buildscript ++ " to recompile."
return True
else do
trace verb $ unlines
[ "Xmobar will not use build script, because "
++ show buildscript ++ " is not executable."
, "Suggested resolution to use it: chmod u+x "
++ show buildscript
]
return False
else do
trace verb $ "Xmobar will use ghc to recompile, because "
++ show buildscript ++ " does not exist."
return False
shouldRecompile :: Bool -> FilePath -> FilePath -> FilePath -> IO Bool
shouldRecompile verb src bin lib = do
libTs <- mapM getModTime . filter isSource =<< allFiles lib
srcT <- getModTime src
binT <- getModTime bin
if any (binT <) (srcT : libTs)
then do
trace verb "Xmobar doing recompile because some files have changed."
return True
else do
trace verb $ "Xmobar skipping recompile because it is not forced "
++ "(e.g. via --recompile), and not any *.hs / *.lhs / *.hsc"
++ "files in lib/ have been changed."
return False
where isSource = flip elem [".hs",".lhs",".hsc"] . takeExtension
allFiles t = do
let prep = map (t</>) . Prelude.filter (`notElem` [".",".."])
cs <- prep <$> E.catch (getDirectoryContents t)
(\(SomeException _) -> return [])
ds <- filterM doesDirectoryExist cs
concat . ((cs \\ ds):) <$> mapM allFiles ds
getModTime f = E.catch (Just <$> getModificationTime f)
(\(SomeException _) -> return Nothing)
runProc :: FilePath -> [String] -> FilePath -> Handle -> IO ProcessHandle
runProc bin args dir eh =
runProcess bin args (Just dir) Nothing Nothing Nothing (Just eh)
xmessage :: String -> IO System.Posix.Types.ProcessID
xmessage msg = forkProcess $
executeFile "xmessage" True ["-default", "okay", replaceUnicode msg] Nothing
where
replaceUnicode = map $ \c -> case c of
'\8226' -> '*'
'\8216' -> '`'
'\8217' -> '`'
_ -> c
ghcErrorMsg :: (Monad m, Show a) => String -> a -> String -> m String
ghcErrorMsg src status ghcErr = return . unlines $
["Error detected while loading xmobar configuration file: " ++ src]
++ lines (if null ghcErr then show status else ghcErr)
++ ["","Please check the file for errors."]
trace :: MonadIO m => Bool -> String -> m ()
trace verb msg = when verb (liftIO $ hPutStrLn stderr msg)
recompile :: MonadIO m => String -> String -> Bool -> Bool -> m Bool
recompile dir execName force verb = liftIO $ do
let bin = dir </> execName
err = dir </> (execName ++ ".errors")
src = dir </> (execName ++ ".hs")
lib = dir </> "lib"
script = dir </> "build"
useScript <- checkBuildScript verb script
sc <- if useScript || force
then return True
else shouldRecompile verb src bin lib
if sc
then do
uninstallSignalHandlers
status <- bracket (openFile err WriteMode) hClose $
\errHandle ->
waitForProcess =<<
if useScript
then runScript script bin dir errHandle
else runGHC bin dir errHandle
installSignalHandlers
if status == ExitSuccess
then trace verb "Xmobar recompilation process exited with success!"
else do
msg <- readFile err >>= ghcErrorMsg src status
hPutStrLn stderr msg
exitWith (ExitFailure 1)
return (status == ExitSuccess)
else return True
where opts bin = ["--make" , execName ++ ".hs" , "-i" , "-ilib"
, "-fforce-recomp" , "-main-is", "main" , "-v0"]
#ifdef THREADED_RUNTIME
++ ["-threaded"]
#endif
#ifdef DRTSOPTS
++ ["-rtsopts", "-with-rtsopts", "-V0"]
#endif
++ ["-o", bin]
runGHC bin = runProc "ghc" (opts bin)
runScript script bin = runProc script [bin]
installSignalHandlers :: MonadIO m => m ()
installSignalHandlers = liftIO $ do
installHandler openEndedPipe Ignore Nothing
installHandler sigCHLD Ignore Nothing
(try :: IO a -> IO (Either SomeException a))
$ fix $ \more -> do
x <- getAnyProcessStatus False False
when (isJust x) more
return ()
uninstallSignalHandlers :: MonadIO m => m ()
uninstallSignalHandlers = liftIO $ do
installHandler openEndedPipe Default Nothing
installHandler sigCHLD Default Nothing
return ()