{-# OPTIONS_GHC -Wunused-imports #-}
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
callCompiler
:: Bool
-> FilePath
-> [String]
-> Maybe FilePath
-> Maybe TextEncoding
-> 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
merrors <- [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe TextEncoding
-> TCM (Maybe [Char])
callCompiler' [Char]
cmd [[Char]]
args Maybe [Char]
cwd Maybe TextEncoding
enc
case merrors of
Maybe [Char]
Nothing -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Char]
errors -> TypeError -> TCM ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError ([Char] -> TypeError
CompilationError [Char]
errors)
else
[Char] -> VerboseLevel -> [Char] -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> VerboseLevel -> [Char] -> m ()
alwaysReportSLn [Char]
"compile.cmd" VerboseLevel
1 ([Char] -> TCM ()) -> [Char] -> TCM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"NOT calling: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char]
cmd [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args)
callCompiler'
:: FilePath
-> [String]
-> Maybe FilePath
-> Maybe TextEncoding
-> 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
[Char] -> VerboseLevel -> [Char] -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> VerboseLevel -> [Char] -> m ()
alwaysReportSLn [Char]
"compile.cmd" VerboseLevel
1 ([Char] -> TCM ()) -> [Char] -> TCM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Calling: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char]
cmd [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args)
(_, out, err, p) <-
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> TCMT
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> TCMT IO a
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
([Char] -> [[Char]] -> CreateProcess
proc [Char]
cmd [[Char]]
args) { std_err = CreatePipe
, std_out = CreatePipe
, cwd = cwd
}
case 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
IO () -> TCM ()
forall a. IO a -> TCMT IO a
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 a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TextEncoding
enc -> IO () -> TCM ()
forall a. IO a -> TCMT IO a
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
progressInfo <- IO [Char] -> TCMT IO [Char]
forall a. IO a -> TCMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> TCMT IO [Char]) -> IO [Char] -> TCMT IO [Char]
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetContents Handle
out
mapM_ (alwaysReportSLn "compile.output" 1) $ lines progressInfo
errors <- liftIO $ case err of
Maybe Handle
Nothing -> IO [Char]
forall a. HasCallStack => a
__IMPOSSIBLE__
Just Handle
err -> do
Handle -> Bool -> IO ()
hSetBinaryMode Handle
err Bool
False
case Maybe TextEncoding
enc of
Maybe TextEncoding
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TextEncoding
enc -> IO () -> IO ()
forall a. IO a -> IO a
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 [Char]
hGetContents Handle
err
exitcode <- liftIO $ do
_ <- E.evaluate (length errors)
waitForProcess p
case exitcode of
ExitFailure VerboseLevel
_ -> Maybe [Char] -> TCM (Maybe [Char])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> TCM (Maybe [Char]))
-> Maybe [Char] -> TCM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
errors
ExitCode
_ -> Maybe [Char] -> TCM (Maybe [Char])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing