{-# LANGUAGE CPP #-}

------------------------------------------------------------------------------
-- |
-- 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, trace, 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 :: FilePath -> IO Bool
isExecutable FilePath
f =
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Permissions -> Bool
executable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Permissions
getPermissions FilePath
f) (\(SomeException e
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

checkBuildScript :: Bool -> FilePath -> IO Bool
checkBuildScript :: Bool -> FilePath -> IO Bool
checkBuildScript Bool
verb FilePath
buildscript = do
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
buildscript
  if Bool
exists
    then do
      Bool
isExe <- FilePath -> IO Bool
isExecutable FilePath
buildscript
      if Bool
isExe
        then do
          forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb forall a b. (a -> b) -> a -> b
$ FilePath
"Xmobar will use build script at "
                       forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
buildscript forall a. [a] -> [a] -> [a]
++ FilePath
" to recompile."
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
          forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
            [ FilePath
"Xmobar will not use build script, because "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
buildscript forall a. [a] -> [a] -> [a]
++ FilePath
" is not executable."
            , FilePath
"Suggested resolution to use it: chmod u+x "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
buildscript
            ]
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else do
      forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb forall a b. (a -> b) -> a -> b
$ FilePath
"Xmobar will use ghc to recompile, because "
                   forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
buildscript forall a. [a] -> [a] -> [a]
++ FilePath
" does not exist."
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

shouldRecompile :: Bool -> FilePath -> FilePath -> FilePath -> IO Bool
shouldRecompile :: Bool -> FilePath -> FilePath -> FilePath -> IO Bool
shouldRecompile Bool
verb FilePath
src FilePath
bin FilePath
lib = do
  [Maybe UTCTime]
libTs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (Maybe UTCTime)
getModTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isSource forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO [FilePath]
allFiles FilePath
lib
  Maybe UTCTime
srcT <- FilePath -> IO (Maybe UTCTime)
getModTime FilePath
src
  Maybe UTCTime
binT <- FilePath -> IO (Maybe UTCTime)
getModTime FilePath
bin
  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe UTCTime
binT forall a. Ord a => a -> a -> Bool
<) (Maybe UTCTime
srcT forall a. a -> [a] -> [a]
: [Maybe UTCTime]
libTs)
    then do
      forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb FilePath
"Xmobar recompiling because some files have changed."
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else do
      forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb forall a b. (a -> b) -> a -> b
$ FilePath
"Xmobar skipping recompile because it is not forced "
                   forall a. [a] -> [a] -> [a]
++ FilePath
"(e.g. via --recompile), and not any *.hs / *.lhs / *.hsc"
                   forall a. [a] -> [a] -> [a]
++ FilePath
" files in lib/ have been changed."
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where isSource :: FilePath -> Bool
isSource = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [FilePath
".hs",FilePath
".lhs",FilePath
".hsc"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension
        allFiles :: FilePath -> IO [FilePath]
allFiles FilePath
t = do
            let prep :: [FilePath] -> [FilePath]
prep = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
tFilePath -> FilePath -> FilePath
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
".",FilePath
".."])
            [FilePath]
cs <- [FilePath] -> [FilePath]
prep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (FilePath -> IO [FilePath]
getDirectoryContents FilePath
t)
                                   (\(SomeException e
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return [])
            [FilePath]
ds <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesDirectoryExist [FilePath]
cs
            forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([FilePath]
cs forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath]
ds)forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [FilePath]
allFiles [FilePath]
ds
        getModTime :: FilePath -> IO (Maybe UTCTime)
getModTime FilePath
f = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime FilePath
f)
                               (\(SomeException e
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)

runProc :: FilePath -> [String] -> FilePath -> Handle -> IO ProcessHandle
runProc :: FilePath -> [FilePath] -> FilePath -> Handle -> IO ProcessHandle
runProc FilePath
bin [FilePath]
args FilePath
dir Handle
eh =
  FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess FilePath
bin [FilePath]
args (forall a. a -> Maybe a
Just FilePath
dir) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Handle
eh)

xmessage :: String -> IO System.Posix.Types.ProcessID
xmessage :: FilePath -> IO ProcessID
xmessage FilePath
msg = IO () -> IO ProcessID
forkProcess forall a b. (a -> b) -> a -> b
$
  forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
executeFile FilePath
"xmessage" Bool
True [FilePath
"-default", FilePath
"okay", FilePath -> FilePath
replaceUnicode FilePath
msg] forall a. Maybe a
Nothing
  where -- Replace some of the unicode symbols GHC uses in its output
        replaceUnicode :: FilePath -> FilePath
replaceUnicode = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \Char
c -> case Char
c of
         Char
'\8226' -> Char
'*'  -- •
         Char
'\8216' -> Char
'`'  -- ‘
         Char
'\8217' -> Char
'`'  -- ’
         Char
_ -> Char
c

ghcErrorMsg :: (Monad m, Show a) => String -> a -> String -> m String
ghcErrorMsg :: forall (m :: * -> *) a.
(Monad m, Show a) =>
FilePath -> a -> FilePath -> m FilePath
ghcErrorMsg FilePath
src a
status FilePath
ghcErr = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines forall a b. (a -> b) -> a -> b
$
  [FilePath
"Error detected while loading xmobar configuration file: " forall a. [a] -> [a] -> [a]
++ FilePath
src]
  forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath]
lines (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
ghcErr then forall a. Show a => a -> FilePath
show a
status else FilePath
ghcErr)
  forall a. [a] -> [a] -> [a]
++ [FilePath
"",FilePath
"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 => Bool -> String -> m ()
trace :: forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb FilePath
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg)

-- | '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 given 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 -> String -> String -> Bool -> Bool -> m Bool
recompile :: forall (m :: * -> *).
MonadIO m =>
FilePath -> FilePath -> FilePath -> Bool -> Bool -> m Bool
recompile FilePath
confDir FilePath
dataDir FilePath
execName Bool
force Bool
verb = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let bin :: FilePath
bin  = FilePath
confDir FilePath -> FilePath -> FilePath
</> FilePath
execName
        err :: FilePath
err  = FilePath
dataDir FilePath -> FilePath -> FilePath
</> (FilePath
execName forall a. [a] -> [a] -> [a]
++ FilePath
".errors")
        src :: FilePath
src  = FilePath
confDir FilePath -> FilePath -> FilePath
</> (FilePath
execName forall a. [a] -> [a] -> [a]
++ FilePath
".hs")
        lib :: FilePath
lib  = FilePath
confDir FilePath -> FilePath -> FilePath
</> FilePath
"lib"
        script :: FilePath
script = FilePath
confDir FilePath -> FilePath -> FilePath
</> FilePath
"build"
    Bool
useScript <- Bool -> FilePath -> IO Bool
checkBuildScript Bool
verb FilePath
script
    Bool
sc <- if Bool
useScript Bool -> Bool -> Bool
|| Bool
force
          then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else Bool -> FilePath -> FilePath -> FilePath -> IO Bool
shouldRecompile Bool
verb FilePath
src FilePath
bin FilePath
lib
    if Bool
sc
      then do
        forall (m :: * -> *). MonadIO m => m ()
uninstallSignalHandlers
        ExitCode
status <- forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
err IOMode
WriteMode) Handle -> IO ()
hClose forall a b. (a -> b) -> a -> b
$
                    \Handle
errHandle ->
                      ProcessHandle -> IO ExitCode
waitForProcess forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                        if Bool
useScript
                        then FilePath -> FilePath -> FilePath -> Handle -> IO ProcessHandle
runScript FilePath
script FilePath
bin FilePath
confDir Handle
errHandle
                        else FilePath -> FilePath -> Handle -> IO ProcessHandle
runGHC FilePath
bin FilePath
confDir Handle
errHandle
        forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers
        if ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
            then forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb FilePath
"Xmobar recompilation process exited with success!"
            else do
                FilePath
msg <- FilePath -> IO FilePath
readFile FilePath
err forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
(Monad m, Show a) =>
FilePath -> a -> FilePath -> m FilePath
ghcErrorMsg FilePath
src ExitCode
status
                Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg
                forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess)
      else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
 where opts :: FilePath -> [FilePath]
opts FilePath
bin = [FilePath
"--make" , FilePath
execName forall a. [a] -> [a] -> [a]
++ FilePath
".hs" , FilePath
"-i" , FilePath
"-ilib"
                  , FilePath
"-fforce-recomp" , FilePath
"-main-is", FilePath
"main" , FilePath
"-v0"]
#ifdef THREADED_RUNTIME
                  ++ ["-threaded"]
#endif
#ifdef RTSOPTS
                  forall a. [a] -> [a] -> [a]
++ [FilePath
"-rtsopts", FilePath
"-with-rtsopts", FilePath
"-V0"]
#endif
                  forall a. [a] -> [a] -> [a]
++ [FilePath
"-o", FilePath
bin]
       runGHC :: FilePath -> FilePath -> Handle -> IO ProcessHandle
runGHC FilePath
bin = FilePath -> [FilePath] -> FilePath -> Handle -> IO ProcessHandle
runProc FilePath
"ghc" (FilePath -> [FilePath]
opts FilePath
bin)
       runScript :: FilePath -> FilePath -> FilePath -> Handle -> IO ProcessHandle
runScript FilePath
script FilePath
bin = FilePath -> [FilePath] -> FilePath -> Handle -> IO ProcessHandle
runProc FilePath
script [FilePath
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 :: forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
openEndedPipe Handler
Ignore forall a. Maybe a
Nothing
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Ignore forall a. Maybe a
Nothing
    (forall e a. Exception e => IO a -> IO (Either e a)
try :: IO a -> IO (Either SomeException a))
      forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
more -> do
        Maybe (ProcessID, ProcessStatus)
x <- Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus Bool
False Bool
False
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (ProcessID, ProcessStatus)
x) IO ()
more
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

uninstallSignalHandlers :: MonadIO m => m ()
uninstallSignalHandlers :: forall (m :: * -> *). MonadIO m => m ()
uninstallSignalHandlers = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
openEndedPipe Handler
Default forall a. Maybe a
Nothing
    Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Default forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return ()