1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
{-# 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 f =
E.catch (executable <$> getPermissions f) (\(SomeException _) -> return False)
checkBuildScript :: Bool -> FilePath -> IO Bool
checkBuildScript verb buildscript = do
exists <- doesFileExist 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 verb 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 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 = 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 :: String -> 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) => String -> a -> String -> 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 => Bool -> String -> m ()
trace verb msg = when verb (liftIO $ hPutStrLn stderr 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 confDir dataDir execName force verb = liftIO $ do
let bin = confDir </> execName
err = dataDir </> (execName ++ ".errors")
src = confDir </> (execName ++ ".hs")
lib = confDir </> "lib"
script = confDir </> "build"
useScript <- checkBuildScript verb script
sc <- if useScript || force
then return True
else shouldRecompile verb src bin lib
if sc
then do
uninstallSignalHandlers
status <- bracket (openFile err WriteMode) hClose $
\errHandle ->
waitForProcess =<<
if useScript
then runScript script bin confDir errHandle
else runGHC bin confDir errHandle
installSignalHandlers
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 bin = ["--make" , execName ++ ".hs" , "-i" , "-ilib"
, "-fforce-recomp" , "-main-is", "main" , "-v0"]
#ifdef THREADED_RUNTIME
++ ["-threaded"]
#endif
#ifdef RTSOPTS
++ ["-rtsopts", "-with-rtsopts", "-V0"]
#endif
#ifdef SHARED_LIBRARIES
++ ["-dynamic"]
#endif
++ ["-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 ()
|
