{-# 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)

----- Haskell Preprocessor -----

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
  -- Use the specified Hs Cpp or try to use the c compiler
  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) [])
  -- Always add the -E flag to the CPP, regardless of the user options
  let rawHsCppProgram :: Program
rawHsCppProgram = String -> Program -> Program
addFlagIfNew String
"-E" Program
foundHsCppProg
  -- Always try to add the Haskell-specific CPP flags, regardless of the user options
  [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}

-- | Given a C preprocessor, figure out how it should be invoked to preprocess
-- Haskell source.
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 []


{- TODO: We want to just check which flags are accepted rather than branching on which compiler
         we are using but this does not match what ./configure does (#23720)

         When we retire configure then this more precise logic can be reinstated.
  withTmpDir $ \dir -> do
  let tmp_h = dir </> "tmp.h"

      -- Werror to ensure that unrecognized warnings result in an error
  let checkFlag flag =
          checking ("for "++flag++" support") $ callProgram cpp ["-Werror", flag, tmp_h]

      tryFlag flag =
          ([flag] <$ checkFlag flag) <|> return []

  writeFile tmp_h ""
  concat <$> sequence
      [ tryFlag "-undef"
      , ["-traditional"] <$ checkFlag "-traditional"
      , tryFlag "-Wno-invalid-pp-token"
      , tryFlag "-Wno-unicode"
      , tryFlag "-Wno-trigraphs"
      ]
      -}

----- C preprocessor -----

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
  -- Use the specified CPP or try to use the c compiler
  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) [])
  -- Check whether the C preprocessor needs -std=gnu99 (only very old toolchains need this)
  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")
        ]
  -- Always add the -E flag to the CPP, regardless of the user options
  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}