{-# LANGUAGE NamedFieldPuns #-}
module GHC.Toolchain.Tools.Cpp (HsCpp(..), findHsCpp, Cpp(..), findCpp) where
import Control.Monad
import System.FilePath
import Data.List(isInfixOf)
import GHC.Toolchain.Prelude
import GHC.Toolchain.Program
import GHC.Toolchain.Tools.Cc
import GHC.Toolchain.Utils (withTempDir, oneOf)
newtype Cpp = Cpp { Cpp -> Program
cppProgram :: Program
}
deriving (Int -> Cpp -> ShowS
[Cpp] -> ShowS
Cpp -> String
(Int -> Cpp -> ShowS)
-> (Cpp -> String) -> ([Cpp] -> ShowS) -> Show Cpp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cpp -> ShowS
showsPrec :: Int -> Cpp -> ShowS
$cshow :: Cpp -> String
show :: Cpp -> String
$cshowList :: [Cpp] -> ShowS
showList :: [Cpp] -> ShowS
Show, ReadPrec [Cpp]
ReadPrec Cpp
Int -> ReadS Cpp
ReadS [Cpp]
(Int -> ReadS Cpp)
-> ReadS [Cpp] -> ReadPrec Cpp -> ReadPrec [Cpp] -> Read Cpp
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Cpp
readsPrec :: Int -> ReadS Cpp
$creadList :: ReadS [Cpp]
readList :: ReadS [Cpp]
$creadPrec :: ReadPrec Cpp
readPrec :: ReadPrec Cpp
$creadListPrec :: ReadPrec [Cpp]
readListPrec :: ReadPrec [Cpp]
Read, Cpp -> Cpp -> Bool
(Cpp -> Cpp -> Bool) -> (Cpp -> Cpp -> Bool) -> Eq Cpp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Cpp -> Cpp -> Bool
== :: Cpp -> Cpp -> Bool
$c/= :: Cpp -> Cpp -> Bool
/= :: Cpp -> Cpp -> Bool
Eq, Eq Cpp
Eq Cpp =>
(Cpp -> Cpp -> Ordering)
-> (Cpp -> Cpp -> Bool)
-> (Cpp -> Cpp -> Bool)
-> (Cpp -> Cpp -> Bool)
-> (Cpp -> Cpp -> Bool)
-> (Cpp -> Cpp -> Cpp)
-> (Cpp -> Cpp -> Cpp)
-> Ord Cpp
Cpp -> Cpp -> Bool
Cpp -> Cpp -> Ordering
Cpp -> Cpp -> Cpp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Cpp -> Cpp -> Ordering
compare :: Cpp -> Cpp -> Ordering
$c< :: Cpp -> Cpp -> Bool
< :: Cpp -> Cpp -> Bool
$c<= :: Cpp -> Cpp -> Bool
<= :: Cpp -> Cpp -> Bool
$c> :: Cpp -> Cpp -> Bool
> :: Cpp -> Cpp -> Bool
$c>= :: Cpp -> Cpp -> Bool
>= :: Cpp -> Cpp -> Bool
$cmax :: Cpp -> Cpp -> Cpp
max :: Cpp -> Cpp -> Cpp
$cmin :: Cpp -> Cpp -> Cpp
min :: Cpp -> Cpp -> Cpp
Ord)
newtype HsCpp = HsCpp { HsCpp -> Program
hsCppProgram :: Program
}
deriving (Int -> HsCpp -> ShowS
[HsCpp] -> ShowS
HsCpp -> String
(Int -> HsCpp -> ShowS)
-> (HsCpp -> String) -> ([HsCpp] -> ShowS) -> Show HsCpp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HsCpp -> ShowS
showsPrec :: Int -> HsCpp -> ShowS
$cshow :: HsCpp -> String
show :: HsCpp -> String
$cshowList :: [HsCpp] -> ShowS
showList :: [HsCpp] -> ShowS
Show, ReadPrec [HsCpp]
ReadPrec HsCpp
Int -> ReadS HsCpp
ReadS [HsCpp]
(Int -> ReadS HsCpp)
-> ReadS [HsCpp]
-> ReadPrec HsCpp
-> ReadPrec [HsCpp]
-> Read HsCpp
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS HsCpp
readsPrec :: Int -> ReadS HsCpp
$creadList :: ReadS [HsCpp]
readList :: ReadS [HsCpp]
$creadPrec :: ReadPrec HsCpp
readPrec :: ReadPrec HsCpp
$creadListPrec :: ReadPrec [HsCpp]
readListPrec :: ReadPrec [HsCpp]
Read, HsCpp -> HsCpp -> Bool
(HsCpp -> HsCpp -> Bool) -> (HsCpp -> HsCpp -> Bool) -> Eq HsCpp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HsCpp -> HsCpp -> Bool
== :: HsCpp -> HsCpp -> Bool
$c/= :: HsCpp -> HsCpp -> Bool
/= :: HsCpp -> HsCpp -> Bool
Eq, Eq HsCpp
Eq HsCpp =>
(HsCpp -> HsCpp -> Ordering)
-> (HsCpp -> HsCpp -> Bool)
-> (HsCpp -> HsCpp -> Bool)
-> (HsCpp -> HsCpp -> Bool)
-> (HsCpp -> HsCpp -> Bool)
-> (HsCpp -> HsCpp -> HsCpp)
-> (HsCpp -> HsCpp -> HsCpp)
-> Ord HsCpp
HsCpp -> HsCpp -> Bool
HsCpp -> HsCpp -> Ordering
HsCpp -> HsCpp -> HsCpp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HsCpp -> HsCpp -> Ordering
compare :: HsCpp -> HsCpp -> Ordering
$c< :: HsCpp -> HsCpp -> Bool
< :: HsCpp -> HsCpp -> Bool
$c<= :: HsCpp -> HsCpp -> Bool
<= :: HsCpp -> HsCpp -> Bool
$c> :: HsCpp -> HsCpp -> Bool
> :: HsCpp -> HsCpp -> Bool
$c>= :: HsCpp -> HsCpp -> Bool
>= :: HsCpp -> HsCpp -> Bool
$cmax :: HsCpp -> HsCpp -> HsCpp
max :: HsCpp -> HsCpp -> HsCpp
$cmin :: HsCpp -> HsCpp -> HsCpp
min :: HsCpp -> HsCpp -> HsCpp
Ord)
findHsCpp :: ProgOpt -> Cc -> M HsCpp
findHsCpp :: ProgOpt -> Cc -> M HsCpp
findHsCpp ProgOpt
progOpt Cc
cc = String -> M HsCpp -> M HsCpp
forall a. Show a => String -> M a -> M a
checking String
"for Haskell C preprocessor" (M HsCpp -> M HsCpp) -> M HsCpp -> M HsCpp
forall a b. (a -> b) -> a -> b
$ do
Program
foundHsCppProg <- String -> ProgOpt -> [String] -> M Program
findProgram String
"Haskell C preprocessor" ProgOpt
progOpt [] M Program -> M Program -> M Program
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Program -> M Program
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgOpt -> String -> [String] -> Program
programFromOpt ProgOpt
progOpt (Program -> String
prgPath (Program -> String) -> Program -> String
forall a b. (a -> b) -> a -> b
$ Cc -> Program
ccProgram Cc
cc) [])
let rawHsCppProgram :: Program
rawHsCppProgram = String -> Program -> Program
addFlagIfNew String
"-E" Program
foundHsCppProg
[String]
hppArgs <- Program -> M [String]
findHsCppArgs Program
rawHsCppProgram
let hsCppProgram :: Program
hsCppProgram = Lens Program [String]
-> ([String] -> [String]) -> Program -> Program
forall a b. Lens a b -> (b -> b) -> a -> a
over Lens Program [String]
_prgFlags ([String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
hppArgs) Program
rawHsCppProgram
HsCpp -> M HsCpp
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return HsCpp{Program
hsCppProgram :: Program
hsCppProgram :: Program
hsCppProgram}
findHsCppArgs :: Program -> M [String]
findHsCppArgs :: Program -> M [String]
findHsCppArgs Program
cpp = (String -> M [String]) -> M [String]
forall a. (String -> M a) -> M a
withTempDir ((String -> M [String]) -> M [String])
-> (String -> M [String]) -> M [String]
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
let tmp_c :: String
tmp_c = String
dir String -> ShowS
</> String
"tmp.c"
String -> String -> M ()
writeFile String
tmp_c String
""
(ExitCode
_, String
stdout0, String
stderr0) <- Program -> [String] -> M (ExitCode, String, String)
readProgram Program
cpp [String
"-x", String
"c", String
tmp_c, String
"-dM", String
"-E"]
if String
"__clang__" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
stdout0 Bool -> Bool -> Bool
|| String
"__clang__" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
stderr0
then [String] -> M [String]
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-undef", String
"-traditional", String
"-Wno-invalid-pp-token", String
"-Wno-unicode", String
"-Wno-trigraphs"]
else do
(ExitCode
_, String
stdout1, String
stderr1) <- Program -> [String] -> M (ExitCode, String, String)
readProgram Program
cpp [String
"-v"]
if String
"gcc" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
stdout1 Bool -> Bool -> Bool
|| String
"gcc" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
stderr1
then [String] -> M [String]
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-undef", String
"-traditional"]
else do
String -> M ()
logDebug String
"Can't recognize your CPP program, you may need to set --with-hs-cpp-flags=FLAGS explicitly"
[String] -> M [String]
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return []
findCpp :: ProgOpt -> Cc -> M Cpp
findCpp :: ProgOpt -> Cc -> M Cpp
findCpp ProgOpt
progOpt Cc
cc = String -> M Cpp -> M Cpp
forall a. Show a => String -> M a -> M a
checking String
"for C preprocessor" (M Cpp -> M Cpp) -> M Cpp -> M Cpp
forall a b. (a -> b) -> a -> b
$ do
Program
foundCppProg <- String -> ProgOpt -> [String] -> M Program
findProgram String
"C preprocessor" ProgOpt
progOpt [] M Program -> M Program -> M Program
forall a. M a -> M a -> M a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Program -> M Program
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgOpt -> String -> [String] -> Program
programFromOpt ProgOpt
progOpt (Program -> String
prgPath (Program -> String) -> Program -> String
forall a b. (a -> b) -> a -> b
$ Cc -> Program
ccProgram Cc
cc) [])
Cc Program
cpp2 <- String -> [M Cc] -> M Cc
forall b. String -> [M b] -> M b
oneOf String
"cc doesn't support C99" ([M Cc] -> M Cc) -> [M Cc] -> M Cc
forall a b. (a -> b) -> a -> b
$ (Cc -> M Cc) -> [Cc] -> [M Cc]
forall a b. (a -> b) -> [a] -> [b]
map Cc -> M Cc
checkC99Support
[ Program -> Cc
Cc Program
foundCppProg
, Program -> Cc
Cc (Program
foundCppProg Program -> (Program -> Program) -> Program
forall a b. a -> (a -> b) -> b
& Lens Program [String]
_prgFlags Lens Program [String] -> String -> Program -> Program
forall a b. Lens a [b] -> b -> a -> a
%++ String
"-std=gnu99")
]
let cppProgram :: Program
cppProgram = String -> Program -> Program
addFlagIfNew String
"-E" Program
cpp2
Cpp -> M Cpp
forall a. a -> M a
forall (m :: * -> *) a. Monad m => a -> m a
return Cpp{Program
cppProgram :: Program
cppProgram :: Program
cppProgram}