-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

-- | Data types for compilers and functions for invoking them.
module Foreign.Hoppy.Generator.Compiler (
  -- * Typeclass
  Compiler (..),
  SomeCompiler (..),
  -- * Data types
  SimpleCompiler (..),
  prependArguments,
  appendArguments,
  overrideCompilerFromEnvironment,
  CustomCompiler (..),
  -- * Standard compilers
  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)

-- | A compiler that exists on the system for compiling C++ code.
class Show a => Compiler a where
  -- | @compileProgram compiler infile outfile@ invokes the given compiler in
  -- the input file, to produce the output file.  If the compiler fails or can't
  -- be called for whatever reason, then an error message is printed to standard
  -- error, and false is returned.
  compileProgram :: a -> FilePath -> FilePath -> IO Bool

  -- | Modifies the compiler to prepend the given paths to the header search
  -- path.
  prependIncludePath :: [FilePath] -> a -> a

-- | An existential data type for 'Compiler's.
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

-- | A compiler that can compile a source file into a binary with a single
-- program invocation.
--
-- Within the strings in this data type, including the program path, all
-- occurences of @{in}@ and @{out}@ are expanded to the input and desired output
-- files, respectively.
data SimpleCompiler = SimpleCompiler
  { SimpleCompiler -> String
scProgram :: FilePath
    -- ^ The name of the compiler program to call.  Lookup is subject to the
    -- regular search path rules of your operating system.
  , SimpleCompiler -> [String]
scArguments :: [String]
    -- ^ Arguments to pass to the compiler.  Each string is passed as a separate
    -- argument.  No further word splitting is done.
  }

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
             }

-- | Adds arguments to the start of a compiler's argument list.
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 }

-- | Adds arguments to the end of a compiler's argument list.
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 }

-- | Modifies a 'SimpleCompiler' based on environment variables.
--
-- If @CXX@ is set and non-empty, it will override the compiler's 'scProgram'.
--
-- If @CXXFLAGS@ is set and non-empty, it will be split into words and each word
-- will be prepended as an argument to 'scArguments'.  Quoting is not supported.
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

-- | A 'Compiler' that allows plugging arbitary logic into the compilation
-- process.
data CustomCompiler = CustomCompiler
  { CustomCompiler -> String
ccLabel :: String
    -- ^ A label to display when the compiler is 'show'n.  The string is
    -- @\"\<CustomCompiler \" ++ label ++ \">\"@.

  , CustomCompiler -> CustomCompiler -> String -> String -> IO Bool
ccCompile :: CustomCompiler -> FilePath -> FilePath -> IO Bool
    -- ^ Given a source file path and an output path, compiles the source file,
    -- producing a binary at the output path.  Returns true on success.  Logs to
    -- standard error and returns false on failure.
    --
    -- This should inspect the compiler argument to make use of its
    -- 'ccHeaderSearchPath'.
    --
    -- The first argument is the 'CustomCompiler' object that this function was
    -- pulled out of.  This is passed in explicitly by 'compileProgram' because
    -- due to the presence of 'prependIncludePath' it's not always possible to
    -- have access to the final compiler object ahead of time.

  , CustomCompiler -> [String]
ccHeaderSearchPath :: [FilePath]
    -- ^ Paths to be searched for C++ header files, in addition to the
    -- compiler's default search directories.
  }

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 }

-- | The default compiler, used by an 'Foreign.Hoppy.Generator.Spec.Interface'
-- that doesn't specify its own.  This will be 'gppCompiler', however if the
-- environment variables @CXX@ or @CXXFLAGS@ are set and nonempty, they will be
-- used.  @CXX@ will override the path to the compiler used, and @CXXFLAGS@ will
-- be split on spaces and appended to the compiler's argument list.
--
-- Specifically, this is defined as:
--
-- @'unsafePerformIO' $ 'overrideCompilerFromEnvironment' 'gppCompiler'@
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

-- | The GNU C++ compiler, invoked as @g++ -o {out} {in}@.
gppCompiler :: SimpleCompiler
gppCompiler :: SimpleCompiler
gppCompiler =
  SimpleCompiler :: String -> [String] -> SimpleCompiler
SimpleCompiler
  { scProgram :: String
scProgram = String
"g++"
  , scArguments :: [String]
scArguments = [String
"-o", String
"{out}", String
"{in}"]
  }

-- | Invokes a program as part of running a compiler.  Performs argument
-- interpolation on the program and argument strings.  Returns true if the
-- program executes successfully, and false otherwise (logging to stderr).
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."