{-# LANGUAGE CPP #-}
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 =
IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Permissions -> Bool
executable (Permissions -> Bool) -> IO Permissions -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Permissions
getPermissions FilePath
f) (\(SomeException e
_) -> Bool -> IO Bool
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
Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Xmobar will use build script at "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
buildscript FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to recompile."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
[ FilePath
"Xmobar will not use build script, because "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
buildscript FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is not executable."
, FilePath
"Suggested resolution to use it: chmod u+x "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
buildscript
]
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do
Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Xmobar will use ghc to recompile, because "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
buildscript FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" does not exist."
Bool -> IO Bool
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 <- (FilePath -> IO (Maybe UTCTime))
-> [FilePath] -> IO [Maybe UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO (Maybe UTCTime)
getModTime ([FilePath] -> IO [Maybe UTCTime])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> IO [Maybe UTCTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isSource ([FilePath] -> IO [Maybe UTCTime])
-> IO [FilePath] -> IO [Maybe UTCTime]
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 (Maybe UTCTime -> Bool) -> [Maybe UTCTime] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe UTCTime
binT Maybe UTCTime -> Maybe UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) (Maybe UTCTime
srcT Maybe UTCTime -> [Maybe UTCTime] -> [Maybe UTCTime]
forall a. a -> [a] -> [a]
: [Maybe UTCTime]
libTs)
then do
Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb FilePath
"Xmobar recompiling because some files have changed."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Xmobar skipping recompile because it is not forced "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"(e.g. via --recompile), and not any *.hs / *.lhs / *.hsc"
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" files in lib/ have been changed."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where isSource :: FilePath -> Bool
isSource = (FilePath -> [FilePath] -> Bool) -> [FilePath] -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [FilePath
".hs",FilePath
".lhs",FilePath
".hsc"] (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
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 = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
tFilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
".",FilePath
".."])
[FilePath]
cs <- [FilePath] -> [FilePath]
prep ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> (SomeException -> IO [FilePath]) -> IO [FilePath]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (FilePath -> IO [FilePath]
getDirectoryContents FilePath
t)
(\(SomeException e
_) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
[FilePath]
ds <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesDirectoryExist [FilePath]
cs
[[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> ([[FilePath]] -> [[FilePath]]) -> [[FilePath]] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([FilePath]
cs [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
\\ [FilePath]
ds)[FilePath] -> [[FilePath]] -> [[FilePath]]
forall a. a -> [a] -> [a]
:) ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
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 = IO (Maybe UTCTime)
-> (SomeException -> IO (Maybe UTCTime)) -> IO (Maybe UTCTime)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime FilePath
f)
(\(SomeException e
_) -> Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
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 (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir) Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
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 (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO ()
forall a.
FilePath
-> Bool -> [FilePath] -> Maybe [(FilePath, FilePath)] -> IO a
executeFile FilePath
"xmessage" Bool
True [FilePath
"-default", FilePath
"okay", FilePath -> FilePath
replaceUnicode FilePath
msg] Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
where
replaceUnicode :: FilePath -> FilePath
replaceUnicode = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> FilePath -> FilePath)
-> (Char -> Char) -> FilePath -> FilePath
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 :: FilePath -> a -> FilePath -> m FilePath
ghcErrorMsg FilePath
src a
status FilePath
ghcErr = FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath)
-> ([FilePath] -> FilePath) -> [FilePath] -> m FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines ([FilePath] -> m FilePath) -> [FilePath] -> m FilePath
forall a b. (a -> b) -> a -> b
$
[FilePath
"Error detected while loading xmobar configuration file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src]
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath]
lines (if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
ghcErr then a -> FilePath
forall a. Show a => a -> FilePath
show a
status else FilePath
ghcErr)
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"",FilePath
"Please check the file for errors."]
trace :: MonadIO m => Bool -> String -> m ()
trace :: Bool -> FilePath -> m ()
trace Bool
verb FilePath
msg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg)
recompile :: MonadIO m => String -> String -> String -> Bool -> Bool -> m Bool
recompile :: FilePath -> FilePath -> FilePath -> Bool -> Bool -> m Bool
recompile FilePath
confDir FilePath
dataDir FilePath
execName Bool
force Bool
verb = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
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 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".errors")
src :: FilePath
src = FilePath
confDir FilePath -> FilePath -> FilePath
</> (FilePath
execName FilePath -> FilePath -> FilePath
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 Bool -> IO Bool
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
IO ()
forall (m :: * -> *). MonadIO m => m ()
uninstallSignalHandlers
ExitCode
status <- IO Handle
-> (Handle -> IO ()) -> (Handle -> IO ExitCode) -> IO ExitCode
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 ((Handle -> IO ExitCode) -> IO ExitCode)
-> (Handle -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
\Handle
errHandle ->
ProcessHandle -> IO ExitCode
waitForProcess (ProcessHandle -> IO ExitCode) -> IO ProcessHandle -> IO ExitCode
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
IO ()
forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers
if ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then Bool -> FilePath -> IO ()
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 IO FilePath -> (FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ExitCode -> FilePath -> IO FilePath
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
ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess)
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where opts :: FilePath -> [FilePath]
opts FilePath
bin = [FilePath
"--make" , FilePath
execName FilePath -> FilePath -> FilePath
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
[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-rtsopts", FilePath
"-with-rtsopts", FilePath
"-V0"]
#endif
[FilePath] -> [FilePath] -> [FilePath]
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]
installSignalHandlers :: MonadIO m => m ()
installSignalHandlers :: m ()
installSignalHandlers = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
openEndedPipe Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Ignore Maybe SignalSet
forall a. Maybe a
Nothing
(forall a. IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try :: IO a -> IO (Either SomeException a))
(IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (ProcessID, ProcessStatus) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ProcessID, ProcessStatus)
x) IO ()
more
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
uninstallSignalHandlers :: MonadIO m => m ()
uninstallSignalHandlers :: m ()
uninstallSignalHandlers = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
openEndedPipe Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigCHLD Handler
Default Maybe SignalSet
forall a. Maybe a
Nothing
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()