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
prependIncludePath :: [FilePath] -> a -> a
data SomeCompiler = forall a. Compiler a => SomeCompiler a
instance Show SomeCompiler where
show :: SomeCompiler -> String
show (SomeCompiler a
c) = String
"<SomeCompiler " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
instance Compiler SomeCompiler where
compileProgram :: SomeCompiler -> String -> String -> IO Bool
compileProgram (SomeCompiler a
c) = a -> String -> String -> IO Bool
forall a. Compiler a => a -> String -> String -> IO Bool
compileProgram a
c
prependIncludePath :: [String] -> SomeCompiler -> SomeCompiler
prependIncludePath [String]
paths (SomeCompiler a
c) = a -> SomeCompiler
forall a. Compiler a => a -> SomeCompiler
SomeCompiler (a -> SomeCompiler) -> a -> SomeCompiler
forall a b. (a -> b) -> a -> b
$ [String] -> a -> a
forall a. Compiler a => [String] -> a -> a
prependIncludePath [String]
paths a
c
data SimpleCompiler = SimpleCompiler
{ SimpleCompiler -> String
scProgram :: FilePath
, SimpleCompiler -> [String]
scArguments :: [String]
}
instance Show SimpleCompiler where
show :: SimpleCompiler -> String
show SimpleCompiler
compiler =
String
"<SimpleCompiler " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (SimpleCompiler -> String
scProgram SimpleCompiler
compiler) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++
[String] -> String
forall a. Show a => a -> String
show (SimpleCompiler -> [String]
scArguments SimpleCompiler
compiler) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
instance Compiler SimpleCompiler where
compileProgram :: SimpleCompiler -> String -> String -> IO Bool
compileProgram SimpleCompiler
compiler String
inPath String
outPath =
SimpleCompiler
-> String -> [String] -> Map String String -> IO Bool
forall a.
Show a =>
a -> String -> [String] -> Map String String -> IO Bool
runProgram SimpleCompiler
compiler
(SimpleCompiler -> String
scProgram SimpleCompiler
compiler)
(SimpleCompiler -> [String]
scArguments SimpleCompiler
compiler)
([(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String
"in", String
inPath), (String
"out", String
outPath)])
prependIncludePath :: [String] -> SimpleCompiler -> SimpleCompiler
prependIncludePath [String]
paths SimpleCompiler
compiler =
SimpleCompiler
compiler { scArguments :: [String]
scArguments =
(String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
path -> [String
"-I", String
path]) [String]
paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
SimpleCompiler -> [String]
scArguments SimpleCompiler
compiler
}
prependArguments :: [String] -> SimpleCompiler -> SimpleCompiler
prependArguments :: [String] -> SimpleCompiler -> SimpleCompiler
prependArguments [String]
args SimpleCompiler
compiler =
SimpleCompiler
compiler { scArguments :: [String]
scArguments = [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ SimpleCompiler -> [String]
scArguments SimpleCompiler
compiler }
appendArguments :: [String] -> SimpleCompiler -> SimpleCompiler
appendArguments :: [String] -> SimpleCompiler -> SimpleCompiler
appendArguments [String]
args SimpleCompiler
compiler =
SimpleCompiler
compiler { scArguments :: [String]
scArguments = SimpleCompiler -> [String]
scArguments SimpleCompiler
compiler [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args }
overrideCompilerFromEnvironment :: SimpleCompiler -> IO SimpleCompiler
overrideCompilerFromEnvironment :: SimpleCompiler -> IO SimpleCompiler
overrideCompilerFromEnvironment SimpleCompiler
compiler = do
Maybe String
envProgram <- String -> Maybe String -> Maybe String
forall a. Eq a => a -> Maybe a -> Maybe a
filterMaybe String
"" (Maybe String -> Maybe String)
-> IO (Maybe String) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"CXX"
[String]
envArguments <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") ([String] -> [String])
-> (Maybe String -> [String]) -> Maybe String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitOnSpace (String -> [String])
-> (Maybe String -> String) -> Maybe String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> [String]) -> IO (Maybe String) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"CXXFLAGS"
SimpleCompiler -> IO SimpleCompiler
forall (m :: * -> *) a. Monad m => a -> m a
return SimpleCompiler
compiler
{ scProgram :: String
scProgram = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (SimpleCompiler -> String
scProgram SimpleCompiler
compiler) Maybe String
envProgram
, scArguments :: [String]
scArguments = [String]
envArguments [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ SimpleCompiler -> [String]
scArguments SimpleCompiler
compiler
}
where splitOnSpace :: String -> [String]
splitOnSpace = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack ([Text] -> [String]) -> (String -> [Text]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn (String -> Text
pack String
" ") (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
data CustomCompiler = CustomCompiler
{ CustomCompiler -> String
ccLabel :: String
, CustomCompiler -> CustomCompiler -> String -> String -> IO Bool
ccCompile :: CustomCompiler -> FilePath -> FilePath -> IO Bool
, :: [FilePath]
}
instance Show CustomCompiler where
show :: CustomCompiler -> String
show CustomCompiler
c = String
"<CustomCompiler " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CustomCompiler -> String
ccLabel CustomCompiler
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
instance Compiler CustomCompiler where
compileProgram :: CustomCompiler -> String -> String -> IO Bool
compileProgram CustomCompiler
c = CustomCompiler -> CustomCompiler -> String -> String -> IO Bool
ccCompile CustomCompiler
c CustomCompiler
c
prependIncludePath :: [String] -> CustomCompiler -> CustomCompiler
prependIncludePath [String]
paths CustomCompiler
c =
CustomCompiler
c { ccHeaderSearchPath :: [String]
ccHeaderSearchPath = [String]
paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ CustomCompiler -> [String]
ccHeaderSearchPath CustomCompiler
c }
defaultCompiler :: SimpleCompiler
{-# NOINLINE defaultCompiler #-}
defaultCompiler :: SimpleCompiler
defaultCompiler = IO SimpleCompiler -> SimpleCompiler
forall a. IO a -> a
unsafePerformIO (IO SimpleCompiler -> SimpleCompiler)
-> IO SimpleCompiler -> SimpleCompiler
forall a b. (a -> b) -> a -> b
$ SimpleCompiler -> IO SimpleCompiler
overrideCompilerFromEnvironment SimpleCompiler
gppCompiler
gppCompiler :: SimpleCompiler
gppCompiler :: SimpleCompiler
gppCompiler =
SimpleCompiler :: String -> [String] -> SimpleCompiler
SimpleCompiler
{ scProgram :: String
scProgram = String
"g++"
, scArguments :: [String]
scArguments = [String
"-o", String
"{out}", String
"{in}"]
}
runProgram :: Show a => a -> FilePath -> [String] -> M.Map String String -> IO Bool
runProgram :: a -> String -> [String] -> Map String String -> IO Bool
runProgram a
compiler String
rawProgram [String]
rawArgs Map String String
values = do
let interpolationResults :: ([String], [String])
interpolationResults =
[Either String String] -> ([String], [String])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String String] -> ([String], [String]))
-> [Either String String] -> ([String], [String])
forall a b. (a -> b) -> a -> b
$
(String -> Either String String)
-> [String] -> [Either String String]
forall a b. (a -> b) -> [a] -> [b]
map (Map String String -> String -> Either String String
strInterpolate Map String String
values) (String
rawProgramString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rawArgs)
case ([String], [String])
interpolationResults of
(String
unknownKey:[String]
_, [String]
_) -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Error: Hit unknown binding {" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
unknownKey String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"} when executing C++ compiler '" String -> ShowS
forall a. [a] -> [a] -> [a]
++
a -> String
forall a. Show a => a -> String
show a
compiler String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". program = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
rawProgram String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", arguments = " String -> ShowS
forall a. [a] -> [a] -> [a]
++
[String] -> String
forall a. Show a => a -> String
show [String]
rawArgs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
([], String
program:[String]
args) -> do
let cmdLine :: String
cmdLine = String -> [String] -> String
showCommandForUser String
program [String]
args
Either
IOException
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forkResult <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO
(Either
IOException
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO
(Either
IOException
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO
(Either
IOException
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
forall a b. (a -> b) -> a -> b
$ String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
program (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> CreateProcess
proc String
program [String]
args
case Either
IOException
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forkResult of
Left (IOException
e :: IOException) -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Error: Hoppy failed to invoke program (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cmdLine String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Right (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
procHandle) -> do
ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procHandle
case ExitCode
exitCode of
ExitCode
ExitSuccess -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
ExitFailure Int
_ -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error: Hoppy call to program failed (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cmdLine String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")."
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
([], []) -> String -> IO Bool
forall a. HasCallStack => String -> a
error String
"runProgram: Can't get here."