------------------------------------------------------------------------
-- | 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 TextEncoding
     -- ^ Use the given text encoding, if any, when reading the output
     -- from the process (stdout and stderr).
  -> TCM ()
callCompiler :: Bool -> FilePath -> [FilePath] -> Maybe TextEncoding -> TCM ()
callCompiler Bool
doCall FilePath
cmd [FilePath]
args Maybe TextEncoding
enc =
  if Bool
doCall then do
    Maybe FilePath
merrors <- FilePath
-> [FilePath] -> Maybe TextEncoding -> TCM (Maybe FilePath)
callCompiler' FilePath
cmd [FilePath]
args Maybe TextEncoding
enc
    case Maybe FilePath
merrors of
      Maybe FilePath
Nothing     -> () -> TCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just FilePath
errors -> TypeError -> TCM ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (FilePath -> TypeError
CompilationError FilePath
errors)
  else
    FilePath -> VerboseLevel -> FilePath -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
FilePath -> VerboseLevel -> FilePath -> m ()
reportSLn FilePath
"compile.cmd" VerboseLevel
1 (FilePath -> TCM ()) -> FilePath -> TCM ()
forall a b. (a -> b) -> a -> b
$ FilePath
"NOT calling: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (FilePath
cmd FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args)

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

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

  FilePath
errors <- IO FilePath -> TCMT IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> TCMT IO FilePath)
-> IO FilePath -> TCMT IO FilePath
forall a b. (a -> b) -> a -> b
$ case Maybe Handle
err of
    Maybe Handle
Nothing  -> IO FilePath
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  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just TextEncoding
enc -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> TextEncoding -> IO ()
hSetEncoding Handle
err TextEncoding
enc
      Handle -> IO FilePath
hGetContents Handle
err

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

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