{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Misc process handling code for SysTools
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
module GHC.SysTools.Process where

import GHC.Prelude

import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Utils.CliOption

import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
import GHC.Data.FastString

import GHC.IO.Encoding

#if defined(__IO_MANAGER_WINIO__)
import GHC.IO.SubSystem ((<!>))
import GHC.IO.Handle.Windows (handleToHANDLE)
import GHC.Event.Windows (associateHandle')
#endif

import Control.Concurrent
import Data.Char

import System.Exit
import System.Environment
import System.FilePath
import System.IO
import System.IO.Error as IO
import System.Process


-- | Enable process jobs support on Windows if it can be expected to work (e.g.
-- @process >= 1.6.9.0@).
enableProcessJobs :: CreateProcess -> CreateProcess
enableProcessJobs :: CreateProcess -> CreateProcess
enableProcessJobs CreateProcess
opts = CreateProcess
opts { use_process_jobs = True }


-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
    :: CreateProcess
    -> IO (ExitCode, String)    -- ^ stdout
readCreateProcessWithExitCode' :: CreateProcess -> IO (ExitCode, String)
readCreateProcessWithExitCode' CreateProcess
proc = do
    (_, Just outh, _, pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CreateProcess
enableProcessJobs (CreateProcess -> CreateProcess) -> CreateProcess -> CreateProcess
forall a b. (a -> b) -> a -> b
$ CreateProcess
proc{ std_out = CreatePipe }

    -- fork off a thread to start consuming the output
    outMVar <- newEmptyMVar
    let onError :: SomeException -> IO ()
        onError SomeException
exc = MVar (Either SomeException String)
-> Either SomeException String -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException String)
outMVar (SomeException -> Either SomeException String
forall a b. a -> Either a b
Left SomeException
exc)
    _ <- forkIO $ handle onError $ do
      output <- hGetContents' outh
      putMVar outMVar $ Right output

    -- wait on the output
    result <- takeMVar outMVar
    hClose outh
    output <- case result of
      Left SomeException
exc -> SomeException -> IO String
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exc
      Right String
output -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
output

    -- wait on the process
    ex <- waitForProcess pid

    return (ex, output)

replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
replaceVar (String
var, String
value) [(String, String)]
env =
    (String
var, String
value) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
var',String
_) -> String
var String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
var') [(String, String)]
env

-- | Version of @System.Process.readProcessWithExitCode@ that takes a
-- key-value tuple to insert into the environment.
readProcessEnvWithExitCode
    :: String -- ^ program path
    -> [String] -- ^ program args
    -> (String, String) -- ^ addition to the environment
    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
readProcessEnvWithExitCode :: String
-> [String] -> (String, String) -> IO (ExitCode, String, String)
readProcessEnvWithExitCode String
prog [String]
args (String, String)
env_update = do
    current_env <- IO [(String, String)]
getEnvironment
    readCreateProcessWithExitCode (proc prog args) {
        env = Just (replaceVar env_update current_env) } ""

-- Don't let gcc localize version info string, #8825
c_locale_env :: (String, String)
c_locale_env :: (String, String)
c_locale_env = (String
"LANGUAGE", String
"C")

-- If the -B<dir> option is set, add <dir> to PATH.  This works around
-- a bug in gcc on Windows Vista where it can't find its auxiliary
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv :: [Option] -> IO (Maybe [(String, String)])
getGccEnv [Option]
opts =
  if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
b_dirs
     then Maybe [(String, String)] -> IO (Maybe [(String, String)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, String)]
forall a. Maybe a
Nothing
     else do env <- IO [(String, String)]
getEnvironment
             return (Just (mangle_paths env))
 where
  ([String]
b_dirs, [Option]
_) = (Option -> Either String Option)
-> [Option] -> ([String], [Option])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Option -> Either String Option
get_b_opt [Option]
opts

  get_b_opt :: Option -> Either String Option
get_b_opt (Option (Char
'-':Char
'B':String
dir)) = String -> Either String Option
forall a b. a -> Either a b
Left String
dir
  get_b_opt Option
other = Option -> Either String Option
forall a b. b -> Either a b
Right Option
other

  -- Work around #1110 on Windows only (lest we stumble into #17266).
#if defined(mingw32_HOST_OS)
  mangle_paths = map mangle_path
  mangle_path (path,paths) | map toUpper path == "PATH"
        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
  mangle_path other = other
#else
  mangle_paths :: a -> a
mangle_paths = a -> a
forall {a}. a -> a
id
#endif


-----------------------------------------------------------------------------
-- Running an external program

runSomething :: Logger
             -> String          -- For -v message
             -> String          -- Command name (possibly a full path)
                                --      assumed already dos-ified
             -> [Option]        -- Arguments
                                --      runSomething will dos-ify them
             -> IO ()

runSomething :: Logger -> String -> String -> [Option] -> IO ()
runSomething Logger
logger String
phase_name String
pgm [Option]
args =
  Logger
-> ([String] -> [String])
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger [String] -> [String]
forall {a}. a -> a
id String
phase_name String
pgm [Option]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing

-- | Run a command, placing the arguments in an external response file.
--
-- This command is used in order to avoid overlong command line arguments on
-- Windows. The command line arguments are first written to an external,
-- temporary response file, and then passed to the linker via @filepath.
-- response files for passing them in. See:
--
--     https://gcc.gnu.org/wiki/Response_Files
--     https://gitlab.haskell.org/ghc/ghc/issues/10777
runSomethingResponseFile
  :: Logger
  -> TmpFs
  -> TempDir
  -> ([String] -> [String])
  -> String
  -> String
  -> [Option]
  -> Maybe [(String,String)]
  -> IO ()
runSomethingResponseFile :: Logger
-> TmpFs
-> TempDir
-> ([String] -> [String])
-> String
-> String
-> [Option]
-> Maybe [(String, String)]
-> IO ()
runSomethingResponseFile Logger
logger TmpFs
tmpfs TempDir
tmp_dir [String] -> [String]
filter_fn String
phase_name String
pgm [Option]
args Maybe [(String, String)]
mb_env =
    Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, ()))
-> IO ()
forall a.
Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger String
phase_name String
pgm [Option]
args (([String] -> IO (ExitCode, ())) -> IO ())
-> ([String] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
real_args -> do
        fp <- [String] -> IO String
getResponseFile [String]
real_args
        let args = [Char
'@'Char -> String -> String
forall a. a -> [a] -> [a]
:String
fp]
        r <- builderMainLoop logger filter_fn pgm args Nothing mb_env
        return (r,())
  where
    getResponseFile :: [String] -> IO String
getResponseFile [String]
args = do
      fp <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> String -> IO String
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_CurrentModule String
"rsp"
      withFile fp WriteMode $ \Handle
h -> do
          Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
          Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall {t :: * -> *}. Foldable t => t Char -> String
escape [String]
args
      return fp

    -- Note: Response files have backslash-escaping, double quoting, and are
    -- whitespace separated (some implementations use newline, others any
    -- whitespace character). Therefore, escape any backslashes, newlines, and
    -- double quotes in the argument, and surround the content with double
    -- quotes.
    --
    -- Another possibility that could be considered would be to convert
    -- backslashes in the argument to forward slashes. This would generally do
    -- the right thing, since backslashes in general only appear in arguments
    -- as part of file paths on Windows, and the forward slash is accepted for
    -- those. However, escaping is more reliable, in case somehow a backslash
    -- appears in a non-file.
    escape :: t Char -> String
escape t Char
x = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"\""
        , (Char -> String) -> t Char -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\Char
c ->
                case Char
c of
                    Char
'\\' -> String
"\\\\"
                    Char
'\n' -> String
"\\n"
                    Char
'\"' -> String
"\\\""
                    Char
_    -> [Char
c])
            t Char
x
        , String
"\""
        ]

runSomethingFiltered
  :: Logger -> ([String] -> [String]) -> String -> String -> [Option]
  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()

runSomethingFiltered :: Logger
-> ([String] -> [String])
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered Logger
logger [String] -> [String]
filter_fn String
phase_name String
pgm [Option]
args Maybe String
mb_cwd Maybe [(String, String)]
mb_env =
    Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, ()))
-> IO ()
forall a.
Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger String
phase_name String
pgm [Option]
args (([String] -> IO (ExitCode, ())) -> IO ())
-> ([String] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
real_args -> do
        r <- Logger
-> ([String] -> [String])
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop Logger
logger [String] -> [String]
filter_fn String
pgm [String]
real_args Maybe String
mb_cwd Maybe [(String, String)]
mb_env
        return (r,())

runSomethingWith
  :: Logger -> String -> String -> [Option]
  -> ([String] -> IO (ExitCode, a))
  -> IO a

runSomethingWith :: forall a.
Logger
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger String
phase_name String
pgm [Option]
args [String] -> IO (ExitCode, a)
io = do
  let real_args :: [String]
real_args = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ((Option -> String) -> [Option] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Option -> String
showOpt [Option]
args)
      cmdLine :: String
cmdLine = String -> [String] -> String
showCommandForUser String
pgm [String]
real_args
  Logger -> String -> String -> IO a -> IO a
forall a. Logger -> String -> String -> IO a -> IO a
traceCmd Logger
logger String
phase_name String
cmdLine (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ String -> String -> IO (ExitCode, a) -> IO a
forall r. String -> String -> IO (ExitCode, r) -> IO r
handleProc String
pgm String
phase_name (IO (ExitCode, a) -> IO a) -> IO (ExitCode, a) -> IO a
forall a b. (a -> b) -> a -> b
$ [String] -> IO (ExitCode, a)
io [String]
real_args

handleProc :: String -> String -> IO (ExitCode, r) -> IO r
handleProc :: forall r. String -> String -> IO (ExitCode, r) -> IO r
handleProc String
pgm String
phase_name IO (ExitCode, r)
proc = do
    (rc, r) <- IO (ExitCode, r)
proc IO (ExitCode, r)
-> (IOError -> IO (ExitCode, r)) -> IO (ExitCode, r)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` IOError -> IO (ExitCode, r)
handler
    case rc of
      ExitSuccess{} -> r -> IO r
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      ExitFailure Int
n -> GhcException -> IO r
forall a. GhcException -> IO a
throwGhcExceptionIO (
            String -> GhcException
ProgramError (String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
pgm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
" failed in phase `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
phase_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'." String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
" (Exit code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"))
  where
    handler :: IOError -> IO (ExitCode, r)
handler IOError
err =
       if IOError -> Bool
IO.isDoesNotExistError IOError
err
          then IO (ExitCode, r)
does_not_exist
          else GhcException -> IO (ExitCode, r)
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall a. Show a => a -> String
show IOError
err)

    does_not_exist :: IO (ExitCode, r)
does_not_exist = GhcException -> IO (ExitCode, r)
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
InstallationError (String
"could not execute: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pgm))

withPipe :: ((Handle, Handle) -> IO a) -> IO a
withPipe :: forall a. ((Handle, Handle) -> IO a) -> IO a
withPipe = IO (Handle, Handle)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Handle, Handle)
createPipe (((Handle, Handle) -> IO ()) -> ((Handle, Handle) -> IO a) -> IO a)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \ (Handle
readEnd, Handle
writeEnd) -> do
  Handle -> IO ()
hClose Handle
readEnd
  Handle -> IO ()
hClose Handle
writeEnd

builderMainLoop :: Logger -> ([String] -> [String]) -> FilePath
                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
                -> IO ExitCode
builderMainLoop :: Logger
-> ([String] -> [String])
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop Logger
logger [String] -> [String]
filter_fn String
pgm [String]
real_args Maybe String
mb_cwd Maybe [(String, String)]
mb_env = ((Handle, Handle) -> IO ExitCode) -> IO ExitCode
forall a. ((Handle, Handle) -> IO a) -> IO a
withPipe (((Handle, Handle) -> IO ExitCode) -> IO ExitCode)
-> ((Handle, Handle) -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \ (Handle
readEnd, Handle
writeEnd) -> do

#if defined(__IO_MANAGER_WINIO__)
  return () <!> do
    associateHandle' =<< handleToHANDLE readEnd
#endif

  -- We use a mask here rather than a bracket because we want
  -- to distinguish between cleaning up with and without an
  -- exception. This is to avoid calling terminateProcess
  -- unless an exception was raised.
  ((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode)
-> ((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        -- acquire
        -- On Windows due to how exec is emulated the old process will exit and
        -- a new process will be created. This means waiting for termination of
        -- the parent process will get you in a race condition as the child may
        -- not have finished yet.  This caused #16450.  To fix this use a
        -- process job to track all child processes and wait for each one to
        -- finish.
        let procdata :: CreateProcess
procdata =
              CreateProcess -> CreateProcess
enableProcessJobs
              (CreateProcess -> CreateProcess) -> CreateProcess -> CreateProcess
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
proc String
pgm [String]
real_args) {
                cwd = mb_cwd
              , env = mb_env
              , std_in  = CreatePipe

              -- We used to treat stdout/stderr as separate streams, but this
              -- was racy (see #25517).  We now treat them as one stream and
              -- that is fine for our use-case.  We rely on upstream programs
              -- to serialize writes to the two streams appropriately (note
              -- that they already need to do that to produce deterministic
              -- output when used interactively / on the command-line).
              , std_out = UseHandle writeEnd
              , std_err = UseHandle writeEnd
              }
        (Just hStdIn, Nothing, Nothing, hProcess) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
restore (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
          String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
"builderMainLoop" CreateProcess
procdata
        hClose writeEnd
        r <- try $ restore $ do
          getLocaleEncoding >>= hSetEncoding readEnd
          hSetNewlineMode readEnd nativeNewlineMode
          hSetBuffering readEnd LineBuffering
          messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd
          mapM_ processBuildMessage messages
          waitForProcess hProcess
        hClose hStdIn
        case r of
          Left (SomeException e
e) -> do
            ProcessHandle -> IO ()
terminateProcess ProcessHandle
hProcess
            e -> IO ExitCode
forall a e. (HasCallStack, Exception e) => e -> a
throw e
e
          Right ExitCode
s -> do
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
s
  where
    processBuildMessage :: BuildMessage -> IO ()
    processBuildMessage :: BuildMessage -> IO ()
processBuildMessage BuildMessage
msg = do
      case BuildMessage
msg of
        BuildMsg SDoc
msg -> do
          Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg
        BuildError SrcLoc
loc SDoc
msg -> do
          Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
errorDiagnostic (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc)
              (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg

parseBuildMessages :: [String] -> [BuildMessage]
parseBuildMessages :: [String] -> [BuildMessage]
parseBuildMessages [String]
str = [String] -> Maybe BuildMessage -> [BuildMessage]
loop [String]
str Maybe BuildMessage
forall a. Maybe a
Nothing
    where
        loop :: [String] -> Maybe BuildMessage -> [BuildMessage]
        loop :: [String] -> Maybe BuildMessage -> [BuildMessage]
loop []     Maybe BuildMessage
Nothing    = []
        loop []     (Just BuildMessage
err) = [BuildMessage
err]
        loop (String
l:[String]
ls) Maybe BuildMessage
in_err     =
                case Maybe BuildMessage
in_err of
                  Just err :: BuildMessage
err@(BuildError SrcLoc
srcLoc SDoc
msg)
                    | String -> Bool
leading_whitespace String
l ->
                        [String] -> Maybe BuildMessage -> [BuildMessage]
loop [String]
ls (BuildMessage -> Maybe BuildMessage
forall a. a -> Maybe a
Just (SrcLoc -> SDoc -> BuildMessage
BuildError SrcLoc
srcLoc (SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
l)))
                    | Bool
otherwise ->
                        BuildMessage
err BuildMessage -> [BuildMessage] -> [BuildMessage]
forall a. a -> [a] -> [a]
: String -> [String] -> [BuildMessage]
checkError String
l [String]
ls
                  Maybe BuildMessage
Nothing ->
                        String -> [String] -> [BuildMessage]
checkError String
l [String]
ls
                  Maybe BuildMessage
_ -> String -> [BuildMessage]
forall a. HasCallStack => String -> a
panic String
"parseBuildMessages/loop"

        checkError :: String -> [String] -> [BuildMessage]
        checkError :: String -> [String] -> [BuildMessage]
checkError String
l [String]
ls
           = case String -> Maybe (SrcLoc, String)
parseError String
l of
                Maybe (SrcLoc, String)
Nothing ->
                    SDoc -> BuildMessage
BuildMsg (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
l) BuildMessage -> [BuildMessage] -> [BuildMessage]
forall a. a -> [a] -> [a]
: [String] -> Maybe BuildMessage -> [BuildMessage]
loop [String]
ls Maybe BuildMessage
forall a. Maybe a
Nothing
                Just (SrcLoc
srcLoc, String
msg) -> do
                    [String] -> Maybe BuildMessage -> [BuildMessage]
loop [String]
ls (BuildMessage -> Maybe BuildMessage
forall a. a -> Maybe a
Just (SrcLoc -> SDoc -> BuildMessage
BuildError SrcLoc
srcLoc (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
msg)))

        leading_whitespace :: String -> Bool
        leading_whitespace :: String -> Bool
leading_whitespace []    = Bool
False
        leading_whitespace (Char
x:String
_) = Char -> Bool
isSpace Char
x

parseError :: String -> Maybe (SrcLoc, String)
parseError :: String -> Maybe (SrcLoc, String)
parseError String
s0 = case String -> Maybe (String, String)
breakColon String
s0 of
                Just (String
filename, String
s1) ->
                    case String -> Maybe (Int, String)
breakIntColon String
s1 of
                    Just (Int
lineNum, String
s2) ->
                        case String -> Maybe (Int, String)
breakIntColon String
s2 of
                        Just (Int
columnNum, String
s3) ->
                            (SrcLoc, String) -> Maybe (SrcLoc, String)
forall a. a -> Maybe a
Just (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
filename) Int
lineNum Int
columnNum, String
s3)
                        Maybe (Int, String)
Nothing ->
                            (SrcLoc, String) -> Maybe (SrcLoc, String)
forall a. a -> Maybe a
Just (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
filename) Int
lineNum Int
0, String
s2)
                    Maybe (Int, String)
Nothing -> Maybe (SrcLoc, String)
forall a. Maybe a
Nothing
                Maybe (String, String)
Nothing -> Maybe (SrcLoc, String)
forall a. Maybe a
Nothing

-- | Break a line of an error message into a filename and the rest of the line,
-- taking care to ignore colons in Windows drive letters (as noted in #17786).
-- For instance,
--
-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@
-- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@
breakColon :: String -> Maybe (String, String)
breakColon :: String -> Maybe (String, String)
breakColon = String -> String -> Maybe (String, String)
go []
  where
    -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
    go :: String -> String -> Maybe (String, String)
go String
accum  (Char
':':Char
'\\':String
rest) = String -> String -> Maybe (String, String)
go (Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:String
accum) String
rest
    go String
accum  (Char
':':Char
'/':String
rest)  = String -> String -> Maybe (String, String)
go (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
':'Char -> String -> String
forall a. a -> [a] -> [a]
:String
accum) String
rest
    go String
accum  (Char
':':String
rest)      = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String -> String
forall a. [a] -> [a]
reverse String
accum, String
rest)
    go String
accum  (Char
c:String
rest)        = String -> String -> Maybe (String, String)
go (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
accum) String
rest
    go String
_accum []              = Maybe (String, String)
forall a. Maybe a
Nothing

breakIntColon :: String -> Maybe (Int, String)
breakIntColon :: String -> Maybe (Int, String)
breakIntColon String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs of
                       (String
ys, Char
_:String
zs)
                        | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ys) Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAscii String
ys Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
ys ->
                           (Int, String) -> Maybe (Int, String)
forall a. a -> Maybe a
Just (String -> Int
forall a. Read a => String -> a
read String
ys, String
zs)
                       (String, String)
_ -> Maybe (Int, String)
forall a. Maybe a
Nothing

data BuildMessage
  = BuildMsg   !SDoc
  | BuildError !SrcLoc !SDoc