module Foreign.Hoppy.Generator.Compiler (
Compiler (..),
SomeCompiler (..),
SimpleCompiler (..),
prependArguments,
appendArguments,
overrideCompilerFromEnvironment,
CustomCompiler (..),
defaultCompiler,
gppCompiler,
) where
import Control.Exception (IOException, try)
import Data.Either (partitionEithers)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Data.Text (pack, splitOn, unpack)
import Foreign.Hoppy.Generator.Common (filterMaybe, strInterpolate)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
import System.IO (hPutStrLn, stderr)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (createProcess_, proc, showCommandForUser, waitForProcess)
class Show a => Compiler a where
compileProgram :: a -> FilePath -> FilePath -> IO Bool
data SomeCompiler = forall a. Compiler a => SomeCompiler a
instance Show SomeCompiler where
show (SomeCompiler c) = "<SomeCompiler " ++ show c ++ ">"
instance Compiler SomeCompiler where
compileProgram (SomeCompiler c) = compileProgram c
data SimpleCompiler = SimpleCompiler
{ scProgram :: FilePath
, scArguments :: [String]
}
instance Show SimpleCompiler where
show compiler =
"<SimpleCompiler " ++ show (scProgram compiler) ++ " " ++
show (scArguments compiler) ++ ">"
instance Compiler SimpleCompiler where
compileProgram compiler inPath outPath =
runProgram compiler
(scProgram compiler)
(scArguments compiler)
(M.fromList [("in", inPath), ("out", outPath)])
prependArguments :: [String] -> SimpleCompiler -> SimpleCompiler
prependArguments args compiler =
compiler { scArguments = args ++ scArguments compiler }
appendArguments :: [String] -> SimpleCompiler -> SimpleCompiler
appendArguments args compiler =
compiler { scArguments = scArguments compiler ++ args }
overrideCompilerFromEnvironment :: SimpleCompiler -> IO SimpleCompiler
overrideCompilerFromEnvironment compiler = do
envProgram <- filterMaybe "" <$> lookupEnv "CXX"
envArguments <- filter (/= "") . splitOnSpace . fromMaybe "" <$> lookupEnv "CXXFLAGS"
return compiler
{ scProgram = fromMaybe (scProgram compiler) envProgram
, scArguments = envArguments ++ scArguments compiler
}
where splitOnSpace = map unpack . splitOn (pack " ") . pack
data CustomCompiler = CustomCompiler
{ ccLabel :: String
, ccCompile :: FilePath -> FilePath -> IO Bool
}
instance Show CustomCompiler where
show c = "<CustomCompiler " ++ ccLabel c ++ ">"
instance Compiler CustomCompiler where
compileProgram = ccCompile
defaultCompiler :: SimpleCompiler
{-# NOINLINE defaultCompiler #-}
defaultCompiler = unsafePerformIO $ overrideCompilerFromEnvironment gppCompiler
gppCompiler :: SimpleCompiler
gppCompiler =
SimpleCompiler
{ scProgram = "g++"
, scArguments = ["-o", "{out}", "{in}"]
}
runProgram :: Show a => a -> FilePath -> [String] -> M.Map String String -> IO Bool
runProgram compiler rawProgram rawArgs values = do
let interpolationResults =
partitionEithers $
map (strInterpolate values) (rawProgram:rawArgs)
case interpolationResults of
(unknownKey:_, _) -> do
hPutStrLn stderr $
"Error: Hit unknown binding {" ++ unknownKey ++ "} when executing C++ compiler '" ++
show compiler ++ ". program = " ++ show rawProgram ++ ", arguments = " ++
show rawArgs ++ "."
return False
([], program:args) -> do
let cmdLine = showCommandForUser program args
forkResult <- try $ createProcess_ program $ proc program args
case forkResult of
Left (e :: IOException) -> do
hPutStrLn stderr $
"Error: Hoppy failed to invoke program (" ++ cmdLine ++ "): " ++ show e
return False
Right (_, _, _, procHandle) -> do
exitCode <- waitForProcess procHandle
case exitCode of
ExitSuccess -> return True
ExitFailure _ -> do
hPutStrLn stderr $ "Error: Hoppy call to program failed (" ++ cmdLine ++ ")."
return False
([], []) -> error "runProgram: Can't get here."