summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/App
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/App')
-rw-r--r--src/Xmobar/App/Compile.hs187
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 ()