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 -> String
prgPath :: FilePath
                       , Program -> [String]
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 = String -> [String] -> Program
Program String
"sh" []

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

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

_prgFlags :: Lens Program [String]
_prgFlags :: Lens Program [String]
_prgFlags = (Program -> [String])
-> ([String] -> Program -> Program) -> Lens Program [String]
forall a b. (a -> b) -> (b -> a -> a) -> Lens a b
Lens Program -> [String]
prgFlags (\[String]
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 :: String -> Program -> Program
addFlagIfNew String
flag prog :: Program
prog@(Program String
path [String]
flags)
  = if String
flag String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
flags
       then Program
prog
       else String -> [String] -> Program
Program String
path ([String]
flags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
flag])

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

callProgram :: Program -> [String] -> M ()
callProgram :: Program -> [String] -> M ()
callProgram Program
prog [String]
args = do
    code <- Program -> [String] -> M ExitCode
runProgram Program
prog [String]
args
    case code of
      ExitCode
ExitSuccess -> () -> M ()
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ExitFailure Int
n -> String -> M ()
forall a. String -> M a
throwE (Int -> String
forall a. Show a => a -> String
err Int
n)
  where
    cmdline :: [String]
cmdline = [Program -> String
prgPath Program
prog] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Program -> [String]
prgFlags Program
prog [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
    err :: a -> String
err a
n = [String] -> String
unlines
        [ String
"Command failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
cmdline
        , String
"Exited with code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
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 -> [String] -> M (ExitCode, String, String)
readProgram Program
prog [String]
args = do
    Program -> [String] -> M ()
logExecute Program
prog [String]
args
    IO (ExitCode, String, String) -> M (ExitCode, String, String)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String) -> M (ExitCode, String, String))
-> IO (ExitCode, String, String) -> M (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode (Program -> String
prgPath Program
prog) (Program -> [String]
prgFlags Program
prog [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args) String
""

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

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

-- | Program specifier from the command-line.
data ProgOpt = ProgOpt { ProgOpt -> Maybe String
poPath :: Maybe FilePath
                       , ProgOpt -> Maybe [String]
poFlags :: Maybe [String]
                       }

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

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

emptyProgOpt :: ProgOpt
emptyProgOpt :: ProgOpt
emptyProgOpt = Maybe String -> Maybe [String] -> ProgOpt
ProgOpt Maybe String
forall a. Maybe a
Nothing Maybe [String]
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 -> String -> [String] -> Program
programFromOpt ProgOpt
userSpec String
path [String]
flags = Program { prgPath :: String
prgPath = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
path (ProgOpt -> Maybe String
poPath ProgOpt
userSpec), prgFlags :: [String]
prgFlags = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [String]
flags (ProgOpt -> Maybe [String]
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 :: String -> ProgOpt -> [String] -> M Program
findProgram String
description ProgOpt
userSpec [String]
candidates
  | Just String
path <- ProgOpt -> Maybe String
poPath ProgOpt
userSpec = do
      let err :: String
err = [String] -> String
unlines
            [ String
"Failed to find " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
description String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
            , String
"Looked for user-specified program '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' in the system search path."
            ]
      String -> Program
toProgram (String -> Program) -> M String -> M Program
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> M String
find_it String
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
<|> String -> M Program
forall a. String -> M a
throwE String
err

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

      find_it :: String -> M String
find_it String
name = do
          r <- IO (Maybe String) -> M (Maybe String)
forall a. IO a -> M a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> M (Maybe String))
-> IO (Maybe String) -> M (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
findExecutable String
name
          case r of
            Maybe String
Nothing -> String -> M String
forall a. String -> M a
throwE (String -> M String) -> String -> M String
forall a b. (a -> b) -> a -> b
$ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found in search path"
            Just String
x -> String -> M String
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x

-------------------- 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.
String
-> [String]
-> Lens compiler Program
-> compiler
-> String
-> String
-> M ()
compile String
ext [String]
extraFlags Lens compiler Program
lens compiler
c String
outPath String
program = do
    let srcPath :: String
srcPath = String
outPath String -> ShowS
<.> String
ext
    String -> String -> M ()
writeFile String
srcPath String
program
    Program -> [String] -> M ()
callProgram (Lens compiler Program -> compiler -> Program
forall a b. Lens a b -> a -> b
view Lens compiler Program
lens compiler
c) ([String] -> M ()) -> [String] -> M ()
forall a b. (a -> b) -> a -> b
$ [String]
extraFlags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-o", String
outPath, String
srcPath]
    String -> String -> M ()
expectFileExists String
outPath String
"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 ())
-> String
-> compiler
-> M compiler
supportsTarget ArchOS
archOs Lens compiler Program
lens compiler -> M ()
checkWorks String
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
  | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
"--target=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (Lens compiler [String] -> compiler -> [String]
forall a b. Lens a b -> a -> b
view (Lens compiler Program
lens Lens compiler Program
-> Lens Program [String] -> Lens compiler [String]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [String]
_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 [String]
-> ([String] -> [String]) -> compiler -> compiler
forall a b. Lens a b -> (b -> b) -> a -> a
over (Lens compiler Program
lens Lens compiler Program
-> Lens Program [String] -> Lens compiler [String]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [String]
_prgFlags) ((String
"--target="String -> ShowS
forall a. [a] -> [a] -> [a]
++String
llvmTarget)String -> [String] -> [String]
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 [String]
-> ([String] -> [String]) -> compiler -> compiler
forall a b. Lens a b -> (b -> b) -> a -> a
over (Lens compiler Program
lens Lens compiler Program
-> Lens Program [String] -> Lens compiler [String]
forall a b c. Lens a b -> Lens b c -> Lens a c
% Lens Program [String]
_prgFlags) (String
"-Werror"String -> [String] -> [String]
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