mach

  1{-# LANGUAGE LambdaCase #-}
  2
  3module Mach.Exec
  4  ( mkConfig,
  5    maybeBuild,
  6    targetOrFile,
  7    ExecConfig,
  8  )
  9where
 10
 11import Control.Exception (catch, throwIO)
 12import Control.Monad (filterM, unless, when)
 13import Data.List (find)
 14import Data.Maybe (catMaybes)
 15import Mach.Error (MakeErr (..))
 16import Mach.Eval
 17import qualified Mach.Types as T
 18import System.Directory (doesPathExist, getModificationTime)
 19import System.Exit (ExitCode (ExitFailure, ExitSuccess))
 20import System.IO (Handle, hFlush, hPutStrLn, stderr, stdout)
 21import System.Process (ProcessHandle, StdStream (UseHandle), createProcess_, shell, std_out, waitForProcess)
 22
 23-- | Configuration regarding the execution of Makefiles.
 24data ExecConfig = ExecConfig
 25  { -- | Handle used for all output
 26    output :: Handle,
 27    -- | Continue execution of indepentent targets on error.
 28    contExec :: Bool,
 29    -- | Command line flags.
 30    flags :: [T.Flag],
 31    -- | Print commands instead of executing them
 32    dryRun :: Bool,
 33    -- | Silent targets (.SILENT special target)
 34    silenced :: Maybe [String],
 35    -- | Ignored targets (.IGNORE special target)
 36    ignored :: Maybe [String],
 37    -- | .PHONY targets.
 38    phonies :: [String]
 39  }
 40
 41mkConfig :: MkDef -> Handle -> [T.Flag] -> ExecConfig
 42mkConfig mkDef handle cflags =
 43  let cnExec = not $ execTerminate cflags
 44      ignAll = not $ null [() | T.IgnoreAll <- cflags]
 45      slnAll = not $ null [() | T.SilentAll <- cflags]
 46      noExec = not $ null [() | T.DryRun <- cflags]
 47   in ExecConfig
 48        { output = handle,
 49          contExec = cnExec,
 50          flags = cflags,
 51          dryRun = noExec,
 52          silenced = if slnAll then Just [] else silent mkDef,
 53          ignored = if ignAll then Just [] else ignore mkDef,
 54          phonies = phony mkDef
 55        }
 56  where
 57    isTerminate :: T.Flag -> Bool
 58    isTerminate T.TermOnErr = True
 59    isTerminate _ = False
 60
 61    -- Implements check for precedence of -k and -S.
 62    execTerminate :: [T.Flag] -> Bool
 63    execTerminate =
 64      maybe True isTerminate
 65        . find
 66          ( \case
 67              T.IgnoreAll -> True
 68              T.ExecCont -> True
 69              _ -> False
 70          )
 71
 72isSilent :: ExecConfig -> Target -> Bool
 73isSilent ExecConfig {silenced = s} tgt =
 74  case s of
 75    Nothing -> False
 76    Just [] -> True
 77    Just xs -> getName tgt `elem` xs
 78
 79isIgnored :: ExecConfig -> Target -> Bool
 80isIgnored ExecConfig {ignored = s} tgt =
 81  case s of
 82    Nothing -> False
 83    Just [] -> True
 84    Just xs -> getName tgt `elem` xs
 85
 86isPhony :: ExecConfig -> Target -> Bool
 87isPhony ExecConfig {phonies = lst} tgt = getName tgt `elem` lst
 88
 89makeProc :: ExecConfig -> String -> IO ProcessHandle
 90makeProc ExecConfig {output = handle} cmd = do
 91  (_, _, _, p) <-
 92    if handle == stdout
 93      then createProcess_ [] (shell cmd)
 94      else createProcess_ [] (shell cmd) {std_out = UseHandle handle}
 95  pure p
 96
 97printCmd :: ExecConfig -> Cmd -> IO ()
 98printCmd ExecConfig {output = handle} cmd =
 99  hPutStrLn handle (show cmd) >> hFlush handle
100
101callCmd :: ExecConfig -> Target -> Cmd -> IO ()
102callCmd conf tgt cmd = do
103  p <- makeProc conf $ cmdShell cmd
104  exitCode <- waitForProcess p
105  case exitCode of
106    ExitSuccess -> pure ()
107    ExitFailure _ ->
108      unless (cmdIgnore cmd || isIgnored conf tgt) $
109        throwIO $
110          ExecErr ("non-zero exit: " ++ show cmd)
111
112runCmd :: ExecConfig -> Target -> Cmd -> IO ()
113runCmd conf = if dryRun conf then dryRunCmd else execCmd
114  where
115    execCmd :: Target -> Cmd -> IO ()
116    execCmd tgt cmd = do
117      unless (cmdSilent cmd || isSilent conf tgt) $
118        printCmd conf cmd
119
120      callCmd conf tgt cmd
121
122    dryRunCmd :: Target -> Cmd -> IO ()
123    dryRunCmd tgt cmd = do
124      printCmd conf cmd
125      when (cmdExec cmd) $
126        callCmd conf tgt cmd
127
128runTarget :: ExecConfig -> MkDef -> Target -> IO ()
129runTarget conf mk tgt = mapM_ (runCmd conf tgt) (getCmds mk tgt)
130
131------------------------------------------------------------------------
132
133-- Lookup the given target. If neither a target nor a file with
134-- the given name exists, then return the default target or throw
135-- an error. If no target but a file exists, return Nothing.
136targetOrFile :: MkDef -> String -> IO (Maybe Target)
137targetOrFile mk name = do
138  t <- lookupRule mk name
139  case t of
140    Just x -> pure $ Just x
141    Nothing -> do
142      exists <- doesPathExist name
143      if exists
144        then pure Nothing
145        else either (throwIO . TargetErr) (pure . Just) $ defaultTarget name mk
146
147-- Return all prerequisites which represent targets. If a prerequisite
148-- is neither a target nor an existing file, then an error is thrown.
149getTargetPreqs :: MkDef -> Target -> IO [Target]
150getTargetPreqs mk target =
151  catMaybes <$> mapM (targetOrFile mk) (getPreqs $ getDef target)
152
153-- Return the names of all prerequisites that a newer than the given target.
154newerPreqs :: Target -> IO [FilePath]
155newerPreqs target = do
156  targetTime <- getModificationTime (getName target)
157  filterM (fmap (targetTime <) . getModificationTime) (getPreqs $ getDef target)
158
159-- Check whether the given target is up-to-date, a target shall be
160-- considered up-to-date if it exists and is newer than all of its
161-- dependencies.
162isUp2Date :: Target -> IO Bool
163isUp2Date target = do
164  exists <- doesPathExist (getName target)
165  if not exists
166    then pure False
167    else null <$> newerPreqs target
168
169-- Build a target if it isn't up-to-date.
170--
171-- Returns 'False' for execution errors when executing with `-k`.
172-- Otherwise, an exception is raised on execution errors.
173--
174-- TODO: Consider using Either error handling instead of exceptions.
175maybeBuild :: ExecConfig -> MkDef -> Target -> IO Bool
176maybeBuild conf@ExecConfig {contExec = cont} mk target = do
177  -- Recursively ensure that all prerequisites are up-to-date.
178  res <- getTargetPreqs mk target >>= mapM (maybeBuild conf mk)
179
180  catch
181    ( do
182        up2Date <- isUp2Date target
183        when (not up2Date || isPhony conf target) $
184          runTarget conf mk target
185
186        pure (not $ any (== False) res)
187    )
188    ( \case
189        exception@(ExecErr _) ->
190          if cont
191            then do
192              hPutStrLn stderr $ "mach: Failed to build '" ++ getName target ++ "'"
193              pure False
194            else throwIO exception
195        exception -> throwIO exception
196    )