------------------------------------------------------------------------
-- | A command which calls a compiler
------------------------------------------------------------------------

module Agda.Compiler.CallCompiler where

import qualified Control.Exception as E
import Control.Monad.Trans

import System.Exit
import System.IO
import System.Process

import Agda.TypeChecking.Monad

import Agda.Utils.Impossible

-- | Calls a compiler:
--
-- * Checks the exit code to see if the compiler exits successfully.
--   If not, then an exception is raised, containing the text the
--   compiler printed to stderr (if any).
--
-- * Uses the debug printout machinery to relay any progress
--   information the compiler prints to stdout.

callCompiler
  :: Bool
     -- ^ Should we actually call the compiler
  -> FilePath
     -- ^ The path to the compiler
  -> [String]
     -- ^ Command-line arguments.
  -> Maybe FilePath
     -- ^ The working directory that should be used when the compiler
     -- is invoked. The default is the current working directory.
  -> Maybe TextEncoding
     -- ^ Use the given text encoding, if any, when reading the output
     -- from the process (stdout and stderr).
  -> TCM ()
callCompiler :: Bool
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe TextEncoding
-> TCM ()
callCompiler Bool
doCall [Char]
cmd [[Char]]
args Maybe [Char]
cwd Maybe TextEncoding
enc =
  if Bool
doCall then do
    Maybe [Char]
merrors <- [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe TextEncoding
-> TCM (Maybe [Char])
callCompiler' [Char]
cmd [[Char]]
args Maybe [Char]
cwd Maybe TextEncoding
enc
    case Maybe [Char]
merrors of
      Maybe [Char]
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just [Char]
errors -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError ([Char] -> TypeError
CompilationError [Char]
errors)
  else
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> VerboseLevel -> [Char] -> m ()
reportSLn [Char]
"compile.cmd" VerboseLevel
1 forall a b. (a -> b) -> a -> b
$ [Char]
"NOT calling: " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args)

-- | Generalisation of @callCompiler@ where the raised exception is
-- returned.
callCompiler'
  :: FilePath
     -- ^ The path to the compiler
  -> [String]
     -- ^ Command-line arguments.
  -> Maybe FilePath
     -- ^ The working directory that should be used when the compiler
     -- is invoked. The default is the current working directory.
  -> Maybe TextEncoding
     -- ^ Use the given text encoding, if any, when reading the output
     -- from the process (stdout and stderr).
  -> TCM (Maybe String)
callCompiler' :: [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe TextEncoding
-> TCM (Maybe [Char])
callCompiler' [Char]
cmd [[Char]]
args Maybe [Char]
cwd Maybe TextEncoding
enc = do
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> VerboseLevel -> [Char] -> m ()
reportSLn [Char]
"compile.cmd" VerboseLevel
1 forall a b. (a -> b) -> a -> b
$ [Char]
"Calling: " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char]
cmd forall a. a -> [a] -> [a]
: [[Char]]
args)
  (Maybe Handle
_, Maybe Handle
out, Maybe Handle
err, ProcessHandle
p) <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
               ([Char] -> [[Char]] -> CreateProcess
proc [Char]
cmd [[Char]]
args) { std_err :: StdStream
std_err = StdStream
CreatePipe
                               , std_out :: StdStream
std_out = StdStream
CreatePipe
                               , cwd :: Maybe [Char]
cwd     = Maybe [Char]
cwd
                               }

  -- In -v0 mode we throw away any progress information printed to
  -- stdout.
  case Maybe Handle
out of
    Maybe Handle
Nothing  -> forall a. HasCallStack => a
__IMPOSSIBLE__
    Just Handle
out -> forall a. TCM a -> TCM ()
forkTCM forall a b. (a -> b) -> a -> b
$ do
      -- The handle should be in text mode.
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Bool -> IO ()
hSetBinaryMode Handle
out Bool
False
      case Maybe TextEncoding
enc of
        Maybe TextEncoding
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just TextEncoding
enc -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
out TextEncoding
enc
      [Char]
progressInfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetContents Handle
out
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *).
MonadDebug m =>
[Char] -> VerboseLevel -> [Char] -> m ()
reportSLn [Char]
"compile.output" VerboseLevel
1) forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
progressInfo

  [Char]
errors <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Maybe Handle
err of
    Maybe Handle
Nothing  -> forall a. HasCallStack => a
__IMPOSSIBLE__
    Just Handle
err -> do
      -- The handle should be in text mode.
      Handle -> Bool -> IO ()
hSetBinaryMode Handle
err Bool
False
      case Maybe TextEncoding
enc of
        Maybe TextEncoding
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just TextEncoding
enc -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
err TextEncoding
enc
      Handle -> IO [Char]
hGetContents Handle
err

  ExitCode
exitcode <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    -- Ensure that the output has been read before waiting for the
    -- process.
    VerboseLevel
_ <- forall a. a -> IO a
E.evaluate (forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length [Char]
errors)
    ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p

  case ExitCode
exitcode of
    ExitFailure VerboseLevel
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
errors
    ExitCode
_             -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing