summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/App/Compile.hs
blob: 0a763b4fe91ce297f7769bc345417f6d8469c117 (plain)
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
{-# 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 -> Bool -> Bool -> m Bool
recompile dir execName force verb = liftIO $ do
    let bin  = dir </> execName
        err  = dir </> (execName ++ ".errors")
        src  = dir </> (execName ++ ".hs")
        lib  = dir </> "lib"
        script = dir </> "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 dir errHandle
                        else runGHC bin dir 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 DRTSOPTS
                  ++ ["-rtsopts", "-with-rtsopts", "-V0"]
#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 ()