{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Misc process handling code for SysTools
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
module GHC.SysTools.Process
  ( readCreateProcessWithExitCode'
  , getGccEnv
  , runSomething
  , runSomethingResponseFile
  , runSomethingFiltered
  , runSomethingWith
  ) 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, [Char])
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 [Char])
-> Either SomeException [Char] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException [Char])
outMVar (SomeException -> Either SomeException [Char]
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 [Char]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exc
      Right [Char]
output -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
output

    -- wait on the process
    ex <- waitForProcess pid

    return (ex, output)

-- 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 [([Char], [Char])])
getGccEnv [Option]
opts =
  if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
b_dirs
     then Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
     else do env <- IO [([Char], [Char])]
getEnvironment
             return (Just (mangle_paths env))
 where
  ([[Char]]
b_dirs, [Option]
_) = (Option -> Either [Char] Option)
-> [Option] -> ([[Char]], [Option])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Option -> Either [Char] Option
get_b_opt [Option]
opts

  get_b_opt :: Option -> Either [Char] Option
get_b_opt (Option (Char
'-':Char
'B':[Char]
dir)) = [Char] -> Either [Char] Option
forall a b. a -> Either a b
Left [Char]
dir
  get_b_opt Option
other = Option -> Either [Char] 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 :: [([Char], [Char])] -> [([Char], [Char])]
mangle_paths = (([Char], [Char]) -> ([Char], [Char]))
-> [([Char], [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> ([Char], [Char])
mangle_path
  mangle_path :: ([Char], [Char]) -> ([Char], [Char])
mangle_path ([Char]
path,[Char]
paths) | (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper [Char]
path [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"PATH"
        = ([Char]
path, Char
'\"' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
b_dirs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\";" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
paths)
  mangle_path ([Char], [Char])
other = ([Char], [Char])
other
#else
  mangle_paths = 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 -> [Char] -> [Char] -> [Option] -> IO ()
runSomething Logger
logger [Char]
phase_name [Char]
pgm [Option]
args =
  Logger
-> ([[Char]] -> [[Char]])
-> [Char]
-> [Char]
-> [Option]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ()
runSomethingFiltered Logger
logger [[Char]] -> [[Char]]
forall a. a -> a
id [Char]
phase_name [Char]
pgm [Option]
args Maybe [Char]
forall a. Maybe a
Nothing Maybe [([Char], [Char])]
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
-> ([[Char]] -> [[Char]])
-> [Char]
-> [Char]
-> [Option]
-> Maybe [([Char], [Char])]
-> IO ()
runSomethingResponseFile Logger
logger TmpFs
tmpfs TempDir
tmp_dir [[Char]] -> [[Char]]
filter_fn [Char]
phase_name [Char]
pgm [Option]
args Maybe [([Char], [Char])]
mb_env =
    Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, ()))
-> IO ()
forall a.
Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger [Char]
phase_name [Char]
pgm [Option]
args (([[Char]] -> IO (ExitCode, ())) -> IO ())
-> ([[Char]] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[Char]]
real_args -> do
        fp <- [[Char]] -> IO [Char]
getResponseFile [[Char]]
real_args
        let args = [Char
'@'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
fp]
        r <- builderMainLoop logger filter_fn pgm args Nothing mb_env
        return (r,())
  where
    getResponseFile :: [[Char]] -> IO [Char]
getResponseFile [[Char]]
args = do
      fp <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> [Char] -> IO [Char]
newTempName Logger
logger TmpFs
tmpfs TempDir
tmp_dir TempFileLifetime
TFL_CurrentModule [Char]
"rsp"
      withFile fp WriteMode $ \Handle
h -> do
          Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
          Handle -> [Char] -> IO ()
hPutStr Handle
h ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
forall {t :: * -> *}. Foldable t => t Char -> [Char]
escape [[Char]]
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 -> [Char]
escape t Char
x = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"\""
        , (Char -> [Char]) -> t Char -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\Char
c ->
                case Char
c of
                    Char
'\\' -> [Char]
"\\\\"
                    Char
'\n' -> [Char]
"\\n"
                    Char
'\"' -> [Char]
"\\\""
                    Char
_    -> [Char
c])
            t Char
x
        , [Char]
"\""
        ]

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

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

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

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

handleProc :: String -> String -> IO (ExitCode, r) -> IO r
handleProc :: forall r. [Char] -> [Char] -> IO (ExitCode, r) -> IO r
handleProc [Char]
pgm [Char]
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 (
            [Char] -> GhcException
ProgramError ([Char]
"`" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
takeFileName [Char]
pgm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
" failed in phase `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
phase_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
" (Exit code: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
  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 ([Char] -> GhcException
ProgramError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
err)

    does_not_exist :: IO (ExitCode, r)
does_not_exist =
      GhcException -> IO (ExitCode, r)
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO (ExitCode, r))
-> GhcException -> IO (ExitCode, r)
forall a b. (a -> b) -> a -> b
$
        [Char] -> GhcException
InstallationError ([Char]
phase_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": could not execute: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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
-> ([[Char]] -> [[Char]])
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ExitCode
builderMainLoop Logger
logger [[Char]] -> [[Char]]
filter_fn [Char]
pgm [[Char]]
real_args Maybe [Char]
mb_cwd Maybe [([Char], [Char])]
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__)
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () IO () -> IO () -> IO ()
forall a. a -> a -> a
<!> do
    HANDLE -> IO ()
associateHandle' (HANDLE -> IO ()) -> IO HANDLE -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO HANDLE
handleToHANDLE Handle
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
$ ([Char] -> [[Char]] -> CreateProcess
proc [Char]
pgm [[Char]]
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
$
          [Char]
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ [Char]
"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 :: [[Char]] -> [BuildMessage]
parseBuildMessages [[Char]]
str = [[Char]] -> Maybe BuildMessage -> [BuildMessage]
loop [[Char]]
str Maybe BuildMessage
forall a. Maybe a
Nothing
    where
        loop :: [String] -> Maybe BuildMessage -> [BuildMessage]
        loop :: [[Char]] -> Maybe BuildMessage -> [BuildMessage]
loop []     Maybe BuildMessage
Nothing    = []
        loop []     (Just BuildMessage
err) = [BuildMessage
err]
        loop ([Char]
l:[[Char]]
ls) Maybe BuildMessage
in_err     =
                case Maybe BuildMessage
in_err of
                  Just err :: BuildMessage
err@(BuildError SrcLoc
srcLoc SDoc
msg)
                    | [Char] -> Bool
leading_whitespace [Char]
l ->
                        [[Char]] -> Maybe BuildMessage -> [BuildMessage]
loop [[Char]]
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
$$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
l)))
                    | Bool
otherwise ->
                        BuildMessage
err BuildMessage -> [BuildMessage] -> [BuildMessage]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]] -> [BuildMessage]
checkError [Char]
l [[Char]]
ls
                  Maybe BuildMessage
Nothing ->
                        [Char] -> [[Char]] -> [BuildMessage]
checkError [Char]
l [[Char]]
ls
                  Maybe BuildMessage
_ -> [Char] -> [BuildMessage]
forall a. HasCallStack => [Char] -> a
panic [Char]
"parseBuildMessages/loop"

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

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

parseError :: String -> Maybe (SrcLoc, String)
parseError :: [Char] -> Maybe (SrcLoc, [Char])
parseError [Char]
s0 = case [Char] -> Maybe ([Char], [Char])
breakColon [Char]
s0 of
                Just ([Char]
filename, [Char]
s1) ->
                    case [Char] -> Maybe (Int, [Char])
breakIntColon [Char]
s1 of
                    Just (Int
lineNum, [Char]
s2) ->
                        case [Char] -> Maybe (Int, [Char])
breakIntColon [Char]
s2 of
                        Just (Int
columnNum, [Char]
s3) ->
                            (SrcLoc, [Char]) -> Maybe (SrcLoc, [Char])
forall a. a -> Maybe a
Just (FastString -> Int -> Int -> SrcLoc
mkSrcLoc ([Char] -> FastString
mkFastString [Char]
filename) Int
lineNum Int
columnNum, [Char]
s3)
                        Maybe (Int, [Char])
Nothing ->
                            (SrcLoc, [Char]) -> Maybe (SrcLoc, [Char])
forall a. a -> Maybe a
Just (FastString -> Int -> Int -> SrcLoc
mkSrcLoc ([Char] -> FastString
mkFastString [Char]
filename) Int
lineNum Int
0, [Char]
s2)
                    Maybe (Int, [Char])
Nothing -> Maybe (SrcLoc, [Char])
forall a. Maybe a
Nothing
                Maybe ([Char], [Char])
Nothing -> Maybe (SrcLoc, [Char])
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 :: [Char] -> Maybe ([Char], [Char])
breakColon = [Char] -> [Char] -> Maybe ([Char], [Char])
go []
  where
    -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
    go :: [Char] -> [Char] -> Maybe ([Char], [Char])
go [Char]
accum  (Char
':':Char
'\\':[Char]
rest) = [Char] -> [Char] -> Maybe ([Char], [Char])
go (Char
'\\'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
accum) [Char]
rest
    go [Char]
accum  (Char
':':Char
'/':[Char]
rest)  = [Char] -> [Char] -> Maybe ([Char], [Char])
go (Char
'/'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
accum) [Char]
rest
    go [Char]
accum  (Char
':':[Char]
rest)      = ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
accum, [Char]
rest)
    go [Char]
accum  (Char
c:[Char]
rest)        = [Char] -> [Char] -> Maybe ([Char], [Char])
go (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
accum) [Char]
rest
    go [Char]
_accum []              = Maybe ([Char], [Char])
forall a. Maybe a
Nothing

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

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