module GHC.Toolchain.Program
    ( Program(..)
    , shProgram
    , _prgPath
    , _prgFlags
    , addFlagIfNew
      -- * Running programs
    , runProgram
    , callProgram
    , readProgram
    , readProgramStdout
      -- * Finding 'Program's
    , ProgOpt(..)
    , emptyProgOpt
    , programFromOpt
    , _poPath
    , _poFlags
    , findProgram
     -- * Compiler programs
    , compile
    , supportsTarget
    ) where

import Control.Monad
import Control.Monad.IO.Class
import Data.List (intercalate, isPrefixOf)
import Data.Maybe
import System.FilePath
import System.Directory
import System.Exit
import System.Process hiding (env)

import GHC.Platform.ArchOS
import GHC.Toolchain.Prelude
import GHC.Toolchain.Utils

data Program = Program { Program -> [Char]
prgPath :: FilePath
                       , Program -> [[Char]]
prgFlags :: [String]
                       }
    deriving (ReadPrec [Program]
ReadPrec Program
Int -> ReadS Program
ReadS [Program]
(Int -> ReadS Program)
-> ReadS [Program]
-> ReadPrec Program
-> ReadPrec [Program]
-> Read Program
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Program
readsPrec :: Int -> ReadS Program
$creadList :: ReadS [Program]
readList :: ReadS [Program]
$creadPrec :: ReadPrec Program
readPrec :: ReadPrec Program
$creadListPrec :: ReadPrec [Program]
readListPrec :: ReadPrec [Program]
Read, Program -> Program -> Bool
(Program -> Program -> Bool)
-> (Program -> Program -> Bool) -> Eq Program
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Program -> Program -> Bool
== :: Program -> Program -> Bool
$c/= :: Program -> Program -> Bool
/= :: Program -> Program -> Bool
Eq, Eq Program
Eq Program =>
(Program -> Program -> Ordering)
-> (Program -> Program -> Bool)
-> (Program -> Program -> Bool)
-> (Program -> Program -> Bool)
-> (Program -> Program -> Bool)
-> (Program -> Program -> Program)
-> (Program -> Program -> Program)
-> Ord Program
Program -> Program -> Bool
Program -> Program -> Ordering
Program -> Program -> Program
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Program -> Program -> Ordering
compare :: Program -> Program -> Ordering
$c< :: Program -> Program -> Bool
< :: Program -> Program -> Bool
$c<= :: Program -> Program -> Bool
<= :: Program -> Program -> Bool
$c> :: Program -> Program -> Bool
> :: Program -> Program -> Bool
$c>= :: Program -> Program -> Bool
>= :: Program -> Program -> Bool
$cmax :: Program -> Program -> Program
max :: Program -> Program -> Program
$cmin :: Program -> Program -> Program
min :: Program -> Program -> Program
Ord)

shProgram :: Program
shProgram :: Program
shProgram = [Char] -> [[Char]] -> Program
Program [Char]
"sh" []

instance Show Program where
  -- Normalise filepaths before showing to aid with diffing the target files.
  show :: Program -> [Char]
show (Program [Char]
p [[Char]]
f) = [[Char]] -> [Char]
unwords
    [ [Char]
"Program { prgPath = ", ShowS
forall a. Show a => a -> [Char]
show (ShowS
normalise [Char]
p), [Char]
", prgFlags =", [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
f , [Char]
"}"]

_prgPath :: Lens Program FilePath
_prgPath :: Lens Program [Char]
_prgPath = (Program -> [Char])
-> ([Char] -> Program -> Program) -> Lens Program [Char]
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
Lens Program -> [Char]
prgPath (\[Char]
x Program
o -> Program
o {prgPath = x})

_prgFlags :: Lens Program [String]
_prgFlags :: Lens Program [[Char]]
_prgFlags = (Program -> [[Char]])
-> ([[Char]] -> Program -> Program) -> Lens Program [[Char]]
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
Lens Program -> [[Char]]
prgFlags (\[[Char]]
x Program
o -> Program
o {prgFlags = x})

-- | Prepends a flag to a program's flags if the flag is not in the existing flags.
addFlagIfNew :: String -> Program -> Program
addFlagIfNew :: [Char] -> Program -> Program
addFlagIfNew [Char]
flag prog :: Program
prog@(Program [Char]
path [[Char]]
flags)
  = if [Char]
flag [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
flags
       then Program
prog
       else [Char] -> [[Char]] -> Program
Program [Char]
path ([[Char]]
flags [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
flag])

runProgram :: Program -> [String] -> M ExitCode
runProgram :: Program -> [[Char]] -> M ExitCode
runProgram Program
prog [[Char]]
args = do
    Program -> [[Char]] -> M ()
logExecute Program
prog [[Char]]
args
    let cp :: CreateProcess
cp = ([Char] -> [[Char]] -> CreateProcess
proc (Program -> [Char]
prgPath Program
prog) (Program -> [[Char]]
prgFlags Program
prog [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args))
            { std_out = CreatePipe
            -- , std_err = CreatePipe
            }
    (code, _stdout, _stderr) <- IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char])
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
readCreateProcessWithExitCode CreateProcess
cp [Char]
""
    return code

callProgram :: Program -> [String] -> M ()
callProgram :: Program -> [[Char]] -> M ()
callProgram Program
prog [[Char]]
args = do
    code <- Program -> [[Char]] -> M ExitCode
runProgram Program
prog [[Char]]
args
    case code of
      ExitCode
ExitSuccess -> () -> M ()
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitFailure Int
n -> [[Char]] -> M ()
forall a. [[Char]] -> M a
throwEs (Int -> [[Char]]
forall {a}. Show a => a -> [[Char]]
err Int
n)
  where
    cmdline :: [[Char]]
cmdline = [Program -> [Char]
prgPath Program
prog] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Program -> [[Char]]
prgFlags Program
prog [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args
    err :: a -> [[Char]]
err a
n =
        [ [Char]
"Command failed: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]]
cmdline
        , [Char]
"Exited with code " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
n
        ]

-- | Runs a program with a list of arguments and returns the exit code and the
-- stdout and stderr output
readProgram :: Program -> [String] -> M (ExitCode, String, String)
readProgram :: Program -> [[Char]] -> M (ExitCode, [Char], [Char])
readProgram Program
prog [[Char]]
args = do
    Program -> [[Char]] -> M ()
logExecute Program
prog [[Char]]
args
    IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char])
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode (Program -> [Char]
prgPath Program
prog) (Program -> [[Char]]
prgFlags Program
prog [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args) [Char]
""

-- | Runs a program with a list of arguments and returns the stdout output,
-- ignoring the exit code.
readProgramStdout :: Program -> [String] -> M String
readProgramStdout :: Program -> [[Char]] -> M [Char]
readProgramStdout Program
prog [[Char]]
args = do
    Program -> [[Char]] -> M ()
logExecute Program
prog [[Char]]
args
    (_code, stdout, _stderr) <- IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char])
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char]) -> M (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode (Program -> [Char]
prgPath Program
prog) (Program -> [[Char]]
prgFlags Program
prog [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args) [Char]
""
    -- Ignores the exit code!
    return stdout

logExecute :: Program -> [String] -> M ()
logExecute :: Program -> [[Char]] -> M ()
logExecute Program
prog [[Char]]
args =
    [Char] -> M ()
logDebug ([Char] -> M ()) -> [Char] -> M ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Execute: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
" " ([Program -> [Char]
prgPath Program
prog] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Program -> [[Char]]
prgFlags Program
prog [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args)

-- | Program specifier from the command-line.
data ProgOpt = ProgOpt { ProgOpt -> Maybe [Char]
poPath :: Maybe String
                       -- ^ Refers to the path to an executable, or simply the
                       -- executable name.
                       , ProgOpt -> Maybe [[Char]]
poFlags :: Maybe [String]
                       }

_poPath :: Lens ProgOpt (Maybe FilePath)
_poPath :: Lens ProgOpt (Maybe [Char])
_poPath = (ProgOpt -> Maybe [Char])
-> (Maybe [Char] -> ProgOpt -> ProgOpt)
-> Lens ProgOpt (Maybe [Char])
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
Lens ProgOpt -> Maybe [Char]
poPath (\Maybe [Char]
x ProgOpt
o -> ProgOpt
o {poPath=x})

_poFlags :: Lens ProgOpt (Maybe [String])
_poFlags :: Lens ProgOpt (Maybe [[Char]])
_poFlags = (ProgOpt -> Maybe [[Char]])
-> (Maybe [[Char]] -> ProgOpt -> ProgOpt)
-> Lens ProgOpt (Maybe [[Char]])
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
Lens ProgOpt -> Maybe [[Char]]
poFlags (\Maybe [[Char]]
x ProgOpt
o -> ProgOpt
o {poFlags=x})

emptyProgOpt :: ProgOpt
emptyProgOpt :: ProgOpt
emptyProgOpt = Maybe [Char] -> Maybe [[Char]] -> ProgOpt
ProgOpt Maybe [Char]
forall a. Maybe a
Nothing Maybe [[Char]]
forall a. Maybe a
Nothing

-- | Make a @'Program'@ from user specified program options (@'ProgOpt'@),
-- defaulting to the given path and flags if unspecified in the @'ProgOpt'@.
programFromOpt :: ProgOpt
               -> FilePath -- ^ Program path to default to
               -> [String] -- ^ Program flags to default to
               -> Program
programFromOpt :: ProgOpt -> [Char] -> [[Char]] -> Program
programFromOpt ProgOpt
userSpec [Char]
path [[Char]]
flags = Program { prgPath :: [Char]
prgPath = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
path (ProgOpt -> Maybe [Char]
poPath ProgOpt
userSpec), prgFlags :: [[Char]]
prgFlags = [[Char]] -> Maybe [[Char]] -> [[Char]]
forall a. a -> Maybe a -> a
fromMaybe [[Char]]
flags (ProgOpt -> Maybe [[Char]]
poFlags ProgOpt
userSpec) }

-- | Tries to find the user specified program by path or tries to look for one
-- in the given list of candidates.
--
-- If the 'ProgOpt' program flags are unspecified the program will have an empty list of flags.
findProgram :: String
            -> ProgOpt     -- ^ path provided by user
            -> [FilePath]  -- ^ candidate names
            -> M Program
findProgram :: [Char] -> ProgOpt -> [[Char]] -> M Program
findProgram [Char]
description ProgOpt
userSpec [[Char]]
candidates
  | Just [Char]
path <- ProgOpt -> Maybe [Char]
poPath ProgOpt
userSpec = do
      let err :: [[Char]]
err =
            [ [Char]
"Failed to find " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
description [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
            , [Char]
"Looked for user-specified program '" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
path [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"' in the system search path."
            ]
      [Char] -> Program
toProgram ([Char] -> Program) -> M [Char] -> M Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> M [Char]
find_it [Char]
path M Program -> M Program -> M Program
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [[Char]] -> M Program
forall a. [[Char]] -> M a
throwEs [[Char]]
err

  | Bool
otherwise = do
      env <- M Env
getEnv
      let prefixedCandidates =
              case Env -> Maybe [Char]
targetPrefix Env
env of
                Just [Char]
prefix -> ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
prefix[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) [[Char]]
candidates
                Maybe [Char]
Nothing     -> []
          candidates' = [[Char]]
prefixedCandidates [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
candidates
          err =
            [ [Char]
"Failed to find " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
description [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."
            , [Char]
"Looked for one of " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
candidates' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in the system search path."
            ]
      toProgram <$> oneOf' err (map find_it candidates') <|> throwEs err
  where
      toProgram :: [Char] -> Program
toProgram [Char]
path = Program { prgPath :: [Char]
prgPath = [Char]
path, prgFlags :: [[Char]]
prgFlags = [[Char]] -> Maybe [[Char]] -> [[Char]]
forall a. a -> Maybe a -> a
fromMaybe [] (ProgOpt -> Maybe [[Char]]
poFlags ProgOpt
userSpec) }

      find_it :: [Char] -> M [Char]
find_it [Char]
name = do
          r <- IO (Maybe [Char]) -> M (Maybe [Char])
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> M (Maybe [Char]))
-> IO (Maybe [Char]) -> M (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Maybe [Char])
findExecutable [Char]
name
          case r of
            Maybe [Char]
Nothing -> [Char] -> M [Char]
forall a. [Char] -> M a
throwE ([Char] -> M [Char]) -> [Char] -> M [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" not found in search path"
            -- Use the given `prgPath` or candidate name rather than the
            -- absolute path returned by `findExecutable`.
            Just [Char]
_x -> [Char] -> M [Char]
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
name

-------------------- Compiling utilities --------------------

-- | Compile a program with a given compiler.
--
-- The compiler must
-- * Take the program path as a positional argument
-- * Accept @-o@ to specify output path
compile
    :: FilePath  -- ^ input extension
    -> [String]  -- ^ extra flags
    -> Lens compiler Program
    -> compiler
    -> FilePath  -- ^ output path
    -> String    -- ^ source
    -> M ()
compile :: forall compiler.
[Char]
-> [[Char]]
-> Lens compiler Program
-> compiler
-> [Char]
-> [Char]
-> M ()
compile [Char]
ext [[Char]]
extraFlags Lens compiler Program
lens compiler
c [Char]
outPath [Char]
program = do
    let srcPath :: [Char]
srcPath = [Char]
outPath [Char] -> ShowS
<.> [Char]
ext
    [Char] -> [Char] -> M ()
writeFile [Char]
srcPath [Char]
program
    Program -> [[Char]] -> M ()
callProgram (Lens compiler Program -> compiler -> Program
forall a b. Lens a b -> a -> b
view Lens compiler Program
lens compiler
c) ([[Char]] -> M ()) -> [[Char]] -> M ()
forall a b. (a -> b) -> a -> b
$ [[Char]]
extraFlags [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-o", [Char]
outPath, [Char]
srcPath]
    [Char] -> [Char] -> M ()
expectFileExists [Char]
outPath [Char]
"compiler produced no output"

-- Note [Don't pass --target to emscripten toolchain]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Emscripten's CC wrapper is a bit wonky in that it accepts the `--target`
-- flag when used as a linker yet rejects it as a compiler (e.g. with `-c`).
-- This is exacerbated by the fact that Cabal currently in some cases
-- combines (and therefore conflates) link and compilation flags.
--
-- Ultimately this should be fixed in Cabal but in the meantime we work around it
-- by handling this toolchain specifically in the various
-- "supports --target" checks in `configure` and `ghc-toolchain`.
--
-- Fixes #23744.

-- | Does compiler program support the @--target=<triple>@ option? If so, we should
-- pass it whenever possible to avoid ambiguity and potential compile-time
-- errors (e.g. see #20162).
supportsTarget :: ArchOS
               -> Lens compiler Program
               -> (compiler -> M ()) -- ^ Action to check if compiler with @--target@ flag works
               -> String             -- ^ The LLVM target to use if @cc@ supports @--target@
               -> compiler           -- ^ The compiler to check @--target@ support for
               -> M compiler         -- ^ Return compiler with @--target@ flag if supported
supportsTarget :: forall compiler.
ArchOS
-> Lens compiler Program
-> (compiler -> M ())
-> [Char]
-> compiler
-> M compiler
supportsTarget ArchOS
archOs Lens compiler Program
lens compiler -> M ()
checkWorks [Char]
llvmTarget compiler
c
    -- See Note [Don't pass --target to emscripten toolchain].
  | Arch
ArchJavaScript <- ArchOS -> Arch
archOS_arch ArchOS
archOs
  = compiler -> M compiler
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return compiler
c

    -- No reason to check if the options already contain a --target flag
  | ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char]
"--target=" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (Lens compiler [[Char]] -> compiler -> [[Char]]
forall a b. Lens a b -> a -> b
view (Lens compiler Program
lens Lens compiler Program
-> Lens Program [[Char]] -> Lens compiler [[Char]]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [[Char]]
_prgFlags) compiler
c)
  = compiler -> M compiler
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return compiler
c

  | Bool
otherwise
  = let c' :: compiler
c' = Lens compiler [[Char]]
-> ([[Char]] -> [[Char]]) -> compiler -> compiler
forall a b. Lens a b -> (b -> b) -> a -> a
over (Lens compiler Program
lens Lens compiler Program
-> Lens Program [[Char]] -> Lens compiler [[Char]]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [[Char]]
_prgFlags) (([Char]
"--target="[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
llvmTarget)[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) compiler
c
     in (compiler
c' compiler -> M () -> M compiler
forall a b. a -> M b -> M a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ compiler -> M ()
checkWorks (Lens compiler [[Char]]
-> ([[Char]] -> [[Char]]) -> compiler -> compiler
forall a b. Lens a b -> (b -> b) -> a -> a
over (Lens compiler Program
lens Lens compiler Program
-> Lens Program [[Char]] -> Lens compiler [[Char]]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [[Char]]
_prgFlags) ([Char]
"-Werror"[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:) compiler
c')) M compiler -> M compiler -> M compiler
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> compiler -> M compiler
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return compiler
c