{-# LANGUAGE CPP #-}
module Xmobar.App.Compile(recompile, trace, xmessage) where
import Control.Monad.IO.Class
import Control.Exception.Extensible (bracket, SomeException(..))
import qualified Control.Exception.Extensible as E
import Control.Monad (filterM, when)
import Data.List ((\\))
import System.FilePath((</>), takeExtension)
import System.IO
import System.Directory
import System.Process
import System.Exit
import System.Posix.Process(executeFile, forkProcess)
import System.Posix.Types(ProcessID)
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 a. a -> IO a
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
exists <- FilePath -> IO Bool
doesFileExist FilePath
buildscript
if exists
then do
isExe <- isExecutable buildscript
if isExe
then do
trace verb $ "Xmobar will use build script at "
++ show buildscript ++ " to recompile."
return True
else do
trace verb $ 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 verb $ "Xmobar will use ghc to recompile, because "
++ show buildscript ++ " does not exist."
return 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
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
srcT <- getModTime src
binT <- getModTime bin
if any (binT <) (srcT : libTs)
then do
trace verb "Xmobar recompiling because some files have changed."
return True
else do
trace verb $ "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 :: FilePath -> Bool
isSource = (FilePath -> [FilePath] -> Bool) -> [FilePath] -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> 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
".."])
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
ds <- filterM doesDirectoryExist cs
concat . ((cs \\ ds):) <$> mapM allFiles 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 a. a -> IO a
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 :: forall (m :: * -> *) a.
(Monad m, Show a) =>
FilePath -> a -> FilePath -> m FilePath
ghcErrorMsg FilePath
src a
status FilePath
ghcErr = FilePath -> m FilePath
forall a. a -> m a
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 a. [a] -> 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 :: forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
trace Bool
verb FilePath
msg = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (IO () -> m ()
forall a. IO a -> m a
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 :: forall (m :: * -> *).
MonadIO m =>
FilePath -> FilePath -> FilePath -> Bool -> Bool -> m Bool
recompile FilePath
confDir FilePath
dataDir FilePath
execName Bool
force Bool
verb = IO Bool -> m Bool
forall a. IO a -> m a
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"
useScript <- Bool -> FilePath -> IO Bool
checkBuildScript Bool
verb FilePath
script
sc <- if useScript || force
then return True
else shouldRecompile verb src bin lib
if sc
then do
status <- bracket (openFile err WriteMode) hClose $
\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
if status == ExitSuccess
then trace verb "Xmobar recompilation process exited with success!"
else do
msg <- readFile err >>= ghcErrorMsg src status
hPutStrLn stderr msg
exitWith (ExitFailure 1)
return (status == ExitSuccess)
else return 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
#ifdef SHARED_LIBRARIES
++ ["-dynamic"]
#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]