diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Xmobar/App/Compile.hs | 187 |
1 files changed, 187 insertions, 0 deletions
diff --git a/src/Xmobar/App/Compile.hs b/src/Xmobar/App/Compile.hs new file mode 100644 index 0000000..bc7147c --- /dev/null +++ b/src/Xmobar/App/Compile.hs @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.App.Compile +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Mon Nov 26, 2018 03:36 +-- +-- +-- Utlities to compile xmobar executables on the fly +-- +------------------------------------------------------------------------------ + + +module Xmobar.App.Compile(recompile) 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 + +import Xmobar.App.Config + +isExecutable :: FilePath -> IO Bool +isExecutable f = + E.catch (executable <$> getPermissions f) (\(SomeException _) -> return False) + +checkBuildScript :: FilePath -> IO Bool +checkBuildScript buildscript = do + exists <- doesFileExist buildscript + if exists + then do + isExe <- isExecutable buildscript + if isExe + then do + trace $ "Xmobar will use build script at " + ++ show buildscript ++ " to recompile." + return True + else do + trace $ 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 $ "Xmobar will use ghc to recompile, because " + ++ show buildscript ++ " does not exist." + return False + +shouldRecompile :: FilePath -> FilePath -> FilePath -> IO Bool +shouldRecompile 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 "Xmobar doing recompile because some files have changed." + return True + else do + trace $ "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 :: [Char] -> IO System.Posix.Types.ProcessID +xmessage msg = forkProcess $ + executeFile "xmessage" True ["-default", "okay", replaceUnicode msg] Nothing + where -- Replace some of the unicode symbols GHC uses in its output + replaceUnicode = map $ \c -> case c of + '\8226' -> '*' -- • + '\8216' -> '`' -- ‘ + '\8217' -> '`' -- ’ + _ -> c + +ghcErrorMsg :: (Monad m, Show a) => [Char] -> a -> [Char] -> 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."] + +-- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may +-- be found in your .xsession-errors file +trace :: MonadIO m => String -> m () +trace = liftIO . hPutStrLn stderr + +-- | 'recompile force', recompile the xmobar configuration file when +-- any of the following apply: +-- +-- * force is 'True' +-- +-- * the execName executable does not exist +-- +-- * the xmobar executable is older than .hs or any file in +-- the @lib@ directory (under the configuration directory). +-- +-- The -i flag is used to restrict recompilation to the xmobar.hs file only, +-- and any files in the aforementioned @lib@ directory. +-- +-- Compilation errors (if any) are logged to the @xmobar.errors@ file +-- in the xmobar data directory. If GHC indicates failure with a +-- non-zero exit code, an xmessage displaying that file is spawned. +-- +-- 'False' is returned if there are compilation errors. +-- +recompile :: MonadIO m => String -> Bool -> m Bool +recompile execName force = liftIO $ do + cfgdir <- xmobarConfigDir + datadir <- xmobarDataDir + let bin = datadir </> execName + err = datadir </> (execName ++ ".errors") + src = cfgdir </> (execName ++ ".hs") + lib = cfgdir </> "lib" + script = cfgdir </> "build" + useScript <- checkBuildScript script + sc <- if useScript || force + then return True + else shouldRecompile src bin lib + if sc + then do + uninstallSignalHandlers + status <- bracket (openFile err WriteMode) hClose $ + \errHandle -> + waitForProcess =<< + if useScript + then runScript script bin cfgdir errHandle + else runGHC bin cfgdir errHandle + installSignalHandlers + if status == ExitSuccess + then trace "Xmobar recompilation process exited with success!" + else do + msg <- readFile err >>= ghcErrorMsg src status + hPutStrLn stderr msg + xmessage msg + return () + return (status == ExitSuccess) + else return True + where opts bin = ["--make" , execName ++ ".hs" , "-i" , "-ilib" + , "-fforce-recomp" , "-main-is", "main" , "-v0" , "-o", bin] + runGHC bin = runProc "ghc" (opts bin) + runScript script bin = runProc script [bin] + +-- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to +-- avoid zombie processes, and clean up any extant zombie processes. +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 () |