Compilation functions lifted from xmonad

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 ()