module Gtk2HsC2Hs (c2hsMain)
where
import Data.List (isPrefixOf)
import System.IO (openFile)
import System.Process (runProcess, waitForProcess)
import Control.Monad (when, unless, mapM)
import Data.Maybe (fromJust)
import System.Console.GetOpt
(ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt)
import FNameOps (suffix, basename, dirname, stripSuffix, addPath,
splitSearchPath)
import Errors (interr)
import UNames (saveRootNameSupply, restoreRootNameSupply)
import Binary (Binary(..), putBinFileWithDict, getBinFileWithDict)
import C2HSState (CST, nop, runC2HS, fatal, fatalsHandledBy, getId,
ExitCode(..), stderr, IOMode(..), putStrCIO, hPutStrCIO,
hPutStrLnCIO, exitWithCIO, getProgNameCIO,
ioeGetErrorString, ioeGetFileName, doesFileExistCIO,
removeFileCIO, liftIO,
fileFindInCIO, mktempCIO, openFileCIO, hCloseCIO,
SwitchBoard(..), Traces(..), setTraces,
traceSet, setSwitch, getSwitch, putTraceStr)
import C (AttrC, hsuffix, isuffix, loadAttrC)
import CHS (CHSModule, skipToLangPragma, hasCPP, loadCHS, dumpCHS, loadAllCHI,
hssuffix, chssuffix, dumpCHI)
import GenHeader (genHeader)
import GenBind (expandHooks)
import Version (version, copyright, disclaimer)
import C2HSConfig (cpp, cppopts, cppoptsdef, hpaths, tmpdir)
c2hsMain :: [String] -> IO ()
c2hsMain :: [String] -> IO ()
c2hsMain = (String, String, String) -> CST () () -> IO ()
forall a. (String, String, String) -> CST () a -> IO a
runC2HS (String
version, String
copyright, String
disclaimer) (CST () () -> IO ())
-> ([String] -> CST () ()) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> CST () ()
forall s. [String] -> CST s ()
compile
header :: String -> String -> String -> String
String
version String
copyright String
disclaimer =
String
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
copyright String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
disclaimer
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\nUsage: c2hs [ option... ] header-file binding-file\n"
trailer, errTrailer :: String
trailer :: String
trailer = String
"\n\
\The header file must be a C header file matching the given \
\binding file.\n\
\The dump TYPE can be\n\
\ trace -- trace compiler phases\n\
\ genbind -- trace binding generation\n\
\ ctrav -- trace C declaration traversal\n\
\ chs -- dump the binding file (adds `.dump' to the name)\n"
errTrailer :: String
errTrailer = String
"Try the option `--help' on its own for more information.\n"
data Flag = CPPOpts String
| CPP String
| Dump DumpType
| Help
| Keep
| Include String
| Output String
| OutDir String
| PreComp String
| LockFun String
| Version
| Error String
deriving Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq
data DumpType = Trace
| GenBind
| CTrav
| CHS
deriving DumpType -> DumpType -> Bool
(DumpType -> DumpType -> Bool)
-> (DumpType -> DumpType -> Bool) -> Eq DumpType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DumpType -> DumpType -> Bool
$c/= :: DumpType -> DumpType -> Bool
== :: DumpType -> DumpType -> Bool
$c== :: DumpType -> DumpType -> Bool
Eq
options :: [OptDescr Flag]
options :: [OptDescr Flag]
options = [
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'C']
[String
"cppopts"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
CPPOpts String
"CPPOPTS")
String
"pass CPPOPTS to the C preprocessor",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'c']
[String
"cpp"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
CPP String
"CPP")
String
"use executable CPP to invoke C preprocessor",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'd']
[String
"dump"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
dumpArg String
"TYPE")
String
"dump internal information (for debugging)",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'h', Char
'?']
[String
"help"]
(Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Help)
String
"brief help (the present message)",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'i']
[String
"include"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
Include String
"INCLUDE")
String
"include paths for .chi files",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'k']
[String
"keep"]
(Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Keep)
String
"keep pre-processed C header",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'o']
[String
"output"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
Output String
"FILE")
String
"output result to FILE (should end in .hs)",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
't']
[String
"output-dir"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
OutDir String
"PATH")
String
"place generated files in PATH",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'p']
[String
"precomp"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
PreComp String
"FILE")
String
"generate or read precompiled header file FILE",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'l']
[String
"lock"]
((String -> Flag) -> String -> ArgDescr Flag
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> Flag
LockFun String
"NAME")
String
"wrap each foreign call with the function NAME",
String -> [String] -> ArgDescr Flag -> String -> OptDescr Flag
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v']
[String
"version"]
(Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
NoArg Flag
Version)
String
"show version information"]
dumpArg :: String -> Flag
dumpArg :: String -> Flag
dumpArg String
"trace" = DumpType -> Flag
Dump DumpType
Trace
dumpArg String
"genbind" = DumpType -> Flag
Dump DumpType
GenBind
dumpArg String
"ctrav" = DumpType -> Flag
Dump DumpType
CTrav
dumpArg String
"chs" = DumpType -> Flag
Dump DumpType
CHS
dumpArg String
_ = String -> Flag
Error String
"Illegal dump type."
compile :: [String] -> CST s ()
compile :: [String] -> CST s ()
compile [String]
cmdLine =
do
CST s ()
forall s. CST s ()
setup
case ArgOrder Flag
-> [OptDescr Flag] -> [String] -> ([Flag], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder Flag
forall a. ArgOrder a
RequireOrder [OptDescr Flag]
options [String]
cmdLine of
([Flag
Help] , [] , []) -> [Flag] -> [String] -> CST s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag
Help] []
([Flag
Version], [] , []) -> [Flag] -> [String] -> CST s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag
Version] []
([Flag]
opts , [String]
args, [])
| [String] -> Bool
properArgs [String]
args -> [Flag] -> [String] -> CST s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag]
opts [String]
args
| Bool
otherwise -> [String] -> CST s ()
forall s a. [String] -> CST s a
raiseErrs [String
wrongNoOfArgsErr]
([Flag]
_ , [String]
_ , [String]
errs) -> [String] -> CST s ()
forall s a. [String] -> CST s a
raiseErrs [String]
errs
where
properArgs :: [String] -> Bool
properArgs [String
file1, String
file2] = String -> String
suffix String
file1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hsuffix
Bool -> Bool -> Bool
&& String -> String
suffix String
file2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
chssuffix
properArgs [String]
_ = Bool
False
doExecute :: [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag]
opts [String]
args = [Flag] -> [String] -> PreCST SwitchBoard s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
execute [Flag]
opts [String]
args
PreCST SwitchBoard s ()
-> (IOError -> PreCST SwitchBoard s ()) -> PreCST SwitchBoard s ()
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` IOError -> PreCST SwitchBoard s ()
forall e s b. IOError -> PreCST e s b
failureHandler
wrongNoOfArgsErr :: String
wrongNoOfArgsErr =
String
"Supply the header file followed by the binding file.\n\
\The header file can be omitted if it is supplied in the binding file.\n\
\The binding file can be omitted if the --precomp flag is given.\n"
failureHandler :: IOError -> PreCST e s b
failureHandler IOError
err =
do
let msg :: String
msg = IOError -> String
ioeGetErrorString IOError
err
fnMsg :: String
fnMsg = case IOError -> Maybe String
ioeGetFileName IOError
err of
Maybe String
Nothing -> String
""
Just String
s -> String
" (file: `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"')"
Handle -> String -> PreCST e s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrLnCIO Handle
stderr (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fnMsg)
ExitCode -> PreCST e s b
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (ExitCode -> PreCST e s b) -> ExitCode -> PreCST e s b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
setup :: CST s ()
setup :: CST s ()
setup = do
String -> CST s ()
forall s. String -> CST s ()
setCPP String
cpp
[String] -> CST s ()
forall s. [String] -> CST s ()
addCPPOpts [String]
cppopts
[String] -> CST s ()
forall s. [String] -> CST s ()
addHPaths [String]
hpaths
raiseErrs :: [String] -> CST s a
raiseErrs :: [String] -> CST s a
raiseErrs [String]
errs = do
Handle -> String -> PreCST SwitchBoard s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errs)
Handle -> String -> PreCST SwitchBoard s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr String
errTrailer
ExitCode -> CST s a
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (ExitCode -> CST s a) -> ExitCode -> CST s a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
execute :: [Flag] -> [FilePath] -> CST s ()
execute :: [Flag] -> [String] -> CST s ()
execute [Flag]
opts [String]
args | Flag
Help Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
opts = CST s ()
forall s. CST s ()
help
| Bool
otherwise =
do
let vs :: [Flag]
vs = (Flag -> Bool) -> [Flag] -> [Flag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== Flag
Version) [Flag]
opts
opts' :: [Flag]
opts' = (Flag -> Bool) -> [Flag] -> [Flag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
/= Flag
Version) [Flag]
opts
(Flag -> CST s ()) -> [Flag] -> CST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Flag -> CST s ()
forall s. Flag -> CST s ()
processOpt ([Flag] -> [Flag]
forall a. [a] -> [a]
atMostOne [Flag]
vs [Flag] -> [Flag] -> [Flag]
forall a. [a] -> [a] -> [a]
++ [Flag]
opts')
let (String
headerFile, String
bndFile) = [String] -> (String, String)
determineFileTypes [String]
args
Maybe String
preCompFile <- (SwitchBoard -> Maybe String) -> CST s (Maybe String)
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Maybe String
preCompSB
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe String
preCompFileMaybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe String
forall a. Maybe a
Nothing) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> String -> CST s ()
forall s. String -> String -> CST s ()
preCompileHeader String
headerFile (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
preCompFile)
CST s () -> (IOError -> CST s ()) -> CST s ()
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` IOError -> CST s ()
forall e s b. IOError -> PreCST e s b
ioErrorHandler
let bndFileWithoutSuffix :: String
bndFileWithoutSuffix = String -> String
stripSuffix String
bndFile
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
bndFile) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$ do
String -> CST s ()
forall s. String -> CST s ()
computeOutputName String
bndFileWithoutSuffix
String -> Maybe String -> String -> CST s ()
forall s. String -> Maybe String -> String -> CST s ()
process String
headerFile Maybe String
preCompFile String
bndFileWithoutSuffix
CST s () -> (IOError -> CST s ()) -> CST s ()
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` IOError -> CST s ()
forall e s b. IOError -> PreCST e s b
ioErrorHandler
where
atMostOne :: [a] -> [a]
atMostOne = (([a] -> a -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[a]
_ a
x -> [a
x]) [])
determineFileTypes :: [String] -> (String, String)
determineFileTypes [String
hfile, String
bfile] = (String
hfile, String
bfile)
determineFileTypes [String
file] | String -> String
suffix String
fileString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
hsuffix = (String
file, String
"")
| Bool
otherwise = (String
"", String
file)
determineFileTypes [] = (String
"", String
"")
ioErrorHandler :: IOError -> PreCST e s b
ioErrorHandler IOError
ioerr = do
String
name <- PreCST e s String
forall e s. PreCST e s String
getProgNameCIO
String -> PreCST e s ()
forall e s. String -> PreCST e s ()
putStrCIO (String -> PreCST e s ()) -> String -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$
String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
ioeGetErrorString IOError
ioerr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
ExitCode -> PreCST e s b
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (ExitCode -> PreCST e s b) -> ExitCode -> PreCST e s b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
help :: CST s ()
help :: CST s ()
help = do
(String
version, String
copyright, String
disclaimer) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO (String -> [OptDescr Flag] -> String
forall a. String -> [OptDescr a] -> String
usageInfo (String -> String -> String -> String
header String
version String
copyright String
disclaimer) [OptDescr Flag]
options)
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
trailer
processOpt :: Flag -> CST s ()
processOpt :: Flag -> CST s ()
processOpt (CPPOpts String
cppopt ) = [String] -> CST s ()
forall s. [String] -> CST s ()
addCPPOpts [String
cppopt]
processOpt (CPP String
cpp ) = String -> CST s ()
forall s. String -> CST s ()
setCPP String
cpp
processOpt (Dump DumpType
dt ) = DumpType -> CST s ()
forall s. DumpType -> CST s ()
setDump DumpType
dt
processOpt (Flag
Keep ) = CST s ()
forall s. CST s ()
setKeep
processOpt (Include String
dirs ) = String -> CST s ()
forall s. String -> CST s ()
setInclude String
dirs
processOpt (Output String
fname ) = String -> CST s ()
forall s. String -> CST s ()
setOutput String
fname
processOpt (OutDir String
fname ) = String -> CST s ()
forall s. String -> CST s ()
setOutDir String
fname
processOpt (PreComp String
fname ) = String -> CST s ()
forall s. String -> CST s ()
setPreComp String
fname
processOpt (LockFun String
name ) = String -> CST s ()
forall s. String -> CST s ()
setLockFun String
name
processOpt Flag
Version = do
(String
version, String
_, String
_) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO (String
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
processOpt (Error String
msg ) = String -> CST s ()
forall s. String -> CST s ()
abort String
msg
abort :: String -> CST s ()
abort :: String -> CST s ()
abort String
msg = do
Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrLnCIO Handle
stderr String
msg
Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr String
errTrailer
String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error in command line options"
computeOutputName :: FilePath -> CST s ()
computeOutputName :: String -> CST s ()
computeOutputName String
bndFileNoSuffix =
do
String
output <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
String
outDir <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outDirSB
let dir :: String
dir = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outDir Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output then String -> String
dirname String
bndFileNoSuffix
else if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outDir then String -> String
dirname String
output
else String
outDir
let base :: String
base = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output then String -> String
basename String
bndFileNoSuffix
else String -> String
basename String
output
(SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {
outputSB :: String
outputSB = String
dir String -> String -> String
`addPath` String
base,
outDirSB :: String
outDirSB = String
dir
}
addCPPOpts :: [String] -> CST s ()
addCPPOpts :: [String] -> CST s ()
addCPPOpts [String]
opts =
do
let iopts :: [String]
iopts = [String
opt | String
opt <- [String]
opts, String
"-I" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
opt, String
"-I-" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
opt]
[String] -> CST s ()
forall s. [String] -> CST s ()
addHPaths ([String] -> CST s ())
-> ([String] -> [String]) -> [String] -> CST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2) ([String] -> CST s ()) -> [String] -> CST s ()
forall a b. (a -> b) -> a -> b
$ [String]
iopts
[String] -> CST s ()
forall s. [String] -> CST s ()
addOpts [String]
opts
where
addOpts :: [String] -> CST s ()
addOpts [String]
opts = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$
\SwitchBoard
sb -> SwitchBoard
sb {cppOptsSB :: [String]
cppOptsSB = SwitchBoard -> [String]
cppOptsSB SwitchBoard
sb [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
opts}
setCPP :: FilePath -> CST s ()
setCPP :: String -> CST s ()
setCPP String
fname = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {cppSB :: String
cppSB = String
fname}
addHPaths :: [FilePath] -> CST s ()
addHPaths :: [String] -> CST s ()
addHPaths [String]
paths = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {hpathsSB :: [String]
hpathsSB = [String]
paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ SwitchBoard -> [String]
hpathsSB SwitchBoard
sb}
setDump :: DumpType -> CST s ()
setDump :: DumpType -> CST s ()
setDump DumpType
Trace = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {tracePhasesSW :: Bool
tracePhasesSW = Bool
True}
setDump DumpType
GenBind = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {traceGenBindSW :: Bool
traceGenBindSW = Bool
True}
setDump DumpType
CTrav = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {traceCTravSW :: Bool
traceCTravSW = Bool
True}
setDump DumpType
CHS = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {dumpCHSSW :: Bool
dumpCHSSW = Bool
True}
setKeep :: CST s ()
setKeep :: CST s ()
setKeep = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {keepSB :: Bool
keepSB = Bool
True}
setInclude :: String -> CST s ()
setInclude :: String -> CST s ()
setInclude String
str = do
let fp :: [String]
fp = String -> [String]
splitSearchPath String
str
(SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {chiPathSB :: [String]
chiPathSB = [String]
fp [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (SwitchBoard -> [String]
chiPathSB SwitchBoard
sb)}
setOutput :: FilePath -> CST s ()
setOutput :: String -> CST s ()
setOutput String
fname = do
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> String
suffix String
fname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
hssuffix) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
[String] -> CST s ()
forall s a. [String] -> CST s a
raiseErrs [String
"Output file should end in .hs!\n"]
(SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {outputSB :: String
outputSB = String -> String
stripSuffix String
fname}
setOutDir :: FilePath -> CST s ()
setOutDir :: String -> CST s ()
setOutDir String
fname = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {outDirSB :: String
outDirSB = String
fname}
setHeader :: FilePath -> CST s ()
String
fname = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {headerSB :: String
headerSB = String
fname}
setPreComp :: FilePath -> CST s ()
setPreComp :: String -> CST s ()
setPreComp String
fname = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb { preCompSB :: Maybe String
preCompSB = String -> Maybe String
forall a. a -> Maybe a
Just String
fname }
setLockFun :: String -> CST s ()
setLockFun :: String -> CST s ()
setLockFun String
name = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb { lockFunSB :: Maybe String
lockFunSB = String -> Maybe String
forall a. a -> Maybe a
Just String
name }
process :: FilePath -> Maybe FilePath -> FilePath -> CST s ()
process :: String -> Maybe String -> String -> CST s ()
process String
headerFile Maybe String
preCompFile String
bndFileStripped =
do
(CHSModule
chsMod , String
warnmsgs) <- String -> CST s (CHSModule, String)
forall s. String -> CST s (CHSModule, String)
loadCHS String
bndFile
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
CHSModule
chsMod <- case CHSModule -> Maybe CHSModule
skipToLangPragma CHSModule
chsMod of
Maybe CHSModule
Nothing -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod
Just CHSModule
chsMod | Bool -> Bool
not (CHSModule -> Bool
hasCPP CHSModule
chsMod) -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod
| Bool
otherwise -> do
String
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
let outFileBase :: String
outFileBase = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outFName then String -> String
basename String
bndFile else String
outFName
let ppFile :: String
ppFile = String
outFileBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chssuffix
String
cpp <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
cppSB
[String]
cppOpts <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
cppOptsSB
let args :: [String]
args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
cppoptsdef, String
headerFile, String
bndFile]
String -> CST s ()
forall s. String -> CST s ()
tracePreproc ([String] -> String
unwords (String
cppString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
ExitCode
exitCode <- IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a e s. IO a -> PreCST e s a
liftIO (IO ExitCode -> PreCST SwitchBoard s ExitCode)
-> IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a b. (a -> b) -> a -> b
$ do
Handle
ppHnd <- String -> IOMode -> IO Handle
openFile String
ppFile IOMode
WriteMode
ProcessHandle
process <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cpp [String]
args
Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
ppHnd) Maybe Handle
forall a. Maybe a
Nothing
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
case ExitCode
exitCode of
ExitFailure Int
_ -> String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing chs file"
ExitCode
_ -> CST s ()
forall e s. PreCST e s ()
nop
(CHSModule
chsMod , String
warnmsgs) <- String -> CST s (CHSModule, String)
forall s. String -> CST s (CHSModule, String)
loadCHS String
ppFile
Bool
keep <- (SwitchBoard -> Bool) -> CST s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
keepSB
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keep (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> CST s ()
forall e s. String -> PreCST e s ()
removeFileCIO String
ppFile
case CHSModule -> Maybe CHSModule
skipToLangPragma CHSModule
chsMod of Just CHSModule
chsMod -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod
CHSModule -> CST s ()
forall s. CHSModule -> PreCST SwitchBoard s ()
traceCHSDump CHSModule
chsMod
([String]
header, CHSModule
strippedCHSMod, String
warnmsgs) <- CHSModule -> CST s ([String], CHSModule, String)
forall s. CHSModule -> CST s ([String], CHSModule, String)
genHeader CHSModule
chsMod
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
Bool
pcFileExists <- CST s Bool -> (String -> CST s Bool) -> Maybe String -> CST s Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> CST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) String -> CST s Bool
forall e s. String -> PreCST e s Bool
doesFileExistCIO Maybe String
preCompFile
AttrC
cheader <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
header Bool -> Bool -> Bool
&& Bool
pcFileExists then do
String -> CST s ()
forall s. String -> CST s ()
traceReadPrecomp (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
preCompFile)
WithNameSupply AttrC
cheader <- IO (WithNameSupply AttrC)
-> PreCST SwitchBoard s (WithNameSupply AttrC)
forall a e s. IO a -> PreCST e s a
liftIO (IO (WithNameSupply AttrC)
-> PreCST SwitchBoard s (WithNameSupply AttrC))
-> IO (WithNameSupply AttrC)
-> PreCST SwitchBoard s (WithNameSupply AttrC)
forall a b. (a -> b) -> a -> b
$ String -> IO (WithNameSupply AttrC)
forall a. Binary a => String -> IO a
getBinFileWithDict (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
preCompFile)
AttrC -> PreCST SwitchBoard s AttrC
forall (m :: * -> *) a. Monad m => a -> m a
return AttrC
cheader
else do
String
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
let newHeaderFile :: String
newHeaderFile = String
outFName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsuffix
let preprocFile :: String
preprocFile = String -> String
basename String
newHeaderFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isuffix
Handle
newHeader <- String -> IOMode -> PreCST SwitchBoard s Handle
forall e s. String -> IOMode -> PreCST e s Handle
openFileCIO String
newHeaderFile IOMode
WriteMode
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
headerFile) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrLnCIO Handle
newHeader (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$ String
"#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
headerFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
(String -> CST s ()) -> [String] -> PreCST SwitchBoard s [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
newHeader) [String]
header
Handle -> CST s ()
forall e s. Handle -> PreCST e s ()
hCloseCIO Handle
newHeader
String -> CST s ()
forall s. String -> CST s ()
setHeader String
newHeaderFile
String
cpp <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
cppSB
[String]
cppOpts <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
cppOptsSB
let args :: [String]
args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
newHeaderFile]
String -> CST s ()
forall s. String -> CST s ()
tracePreproc ([String] -> String
unwords (String
cppString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
ExitCode
exitCode <- IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a e s. IO a -> PreCST e s a
liftIO (IO ExitCode -> PreCST SwitchBoard s ExitCode)
-> IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a b. (a -> b) -> a -> b
$ do
Handle
preprocHnd <- String -> IOMode -> IO Handle
openFile String
preprocFile IOMode
WriteMode
ProcessHandle
process <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cpp [String]
args
Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
preprocHnd) Maybe Handle
forall a. Maybe a
Nothing
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
case ExitCode
exitCode of
ExitFailure Int
_ -> String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing custom header file"
ExitCode
_ -> CST s ()
forall e s. PreCST e s ()
nop
(AttrC
cheader, String
warnmsgs) <- String -> CST s (AttrC, String)
forall s. String -> CST s (AttrC, String)
loadAttrC String
preprocFile
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
Bool
keep <- (SwitchBoard -> Bool) -> CST s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
keepSB
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keep (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> CST s ()
forall e s. String -> PreCST e s ()
removeFileCIO String
preprocFile
AttrC -> PreCST SwitchBoard s AttrC
forall (m :: * -> *) a. Monad m => a -> m a
return AttrC
cheader
(CHSModule
hsMod, String
chi, String
warnmsgs) <- AttrC -> CHSModule -> CST s (CHSModule, String, String)
forall s. AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks AttrC
cheader CHSModule
strippedCHSMod
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
String
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
let hsFile :: String
hsFile = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outFName then String -> String
basename String
bndFile else String
outFName
String -> CHSModule -> Bool -> CST s ()
forall s. String -> CHSModule -> Bool -> CST s ()
dumpCHS String
hsFile CHSModule
hsMod Bool
True
String -> String -> CST s ()
forall s. String -> String -> CST s ()
dumpCHI String
hsFile String
chi
where
bndFile :: String
bndFile = String
bndFileStripped String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chssuffix
traceReadPrecomp :: String -> CST s ()
traceReadPrecomp String
fName = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
String
"Reading precompiled header file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...\n"
tracePreproc :: String -> CST s ()
tracePreproc String
cmd = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
String
"Invoking cpp as `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n"
traceCHSDump :: CHSModule -> PreCST SwitchBoard s ()
traceCHSDump CHSModule
mod = do
Bool
flag <- (Traces -> Bool) -> CST s Bool
forall s. (Traces -> Bool) -> CST s Bool
traceSet Traces -> Bool
dumpCHSSW
Bool -> PreCST SwitchBoard s () -> PreCST SwitchBoard s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
flag (PreCST SwitchBoard s () -> PreCST SwitchBoard s ())
-> PreCST SwitchBoard s () -> PreCST SwitchBoard s ()
forall a b. (a -> b) -> a -> b
$
(do
String -> PreCST SwitchBoard s ()
forall e s. String -> PreCST e s ()
putStrCIO (String
"...dumping CHS to `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chsName
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n")
String -> CHSModule -> Bool -> PreCST SwitchBoard s ()
forall s. String -> CHSModule -> Bool -> CST s ()
dumpCHS String
chsName CHSModule
mod Bool
False)
chsName :: String
chsName = String -> String
basename String
bndFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".dump"
preCompileHeader :: FilePath -> FilePath -> CST s ()
String
headerFile String
preCompFile =
do
let preprocFile :: String
preprocFile = String -> String
basename String
headerFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isuffix
Bool
pcFileExists <- String -> PreCST SwitchBoard s Bool
forall e s. String -> PreCST e s Bool
doesFileExistCIO String
preCompFile
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pcFileExists (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$ do
[String]
hpaths <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
hpathsSB
String
realHeaderFile <- String
headerFile String -> [String] -> PreCST SwitchBoard s String
forall e s. String -> [String] -> PreCST e s String
`fileFindInCIO` [String]
hpaths
String
cpp <- (SwitchBoard -> String) -> PreCST SwitchBoard s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
cppSB
[String]
cppOpts <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
cppOptsSB
let args :: [String]
args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
realHeaderFile]
String -> CST s ()
forall s. String -> CST s ()
tracePreproc ([String] -> String
unwords (String
cppString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
ExitCode
exitCode <- IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a e s. IO a -> PreCST e s a
liftIO (IO ExitCode -> PreCST SwitchBoard s ExitCode)
-> IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a b. (a -> b) -> a -> b
$ do
Handle
preprocHnd <- String -> IOMode -> IO Handle
openFile String
preprocFile IOMode
WriteMode
ProcessHandle
process <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cpp [String]
args
Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
preprocHnd) Maybe Handle
forall a. Maybe a
Nothing
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
case ExitCode
exitCode of
ExitFailure Int
_ -> String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing"
ExitCode
_ -> CST s ()
forall e s. PreCST e s ()
nop
(AttrC
cheader, String
warnmsgs) <- String -> CST s (AttrC, String)
forall s. String -> CST s (AttrC, String)
loadAttrC String
preprocFile
String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
IO () -> CST s ()
forall a e s. IO a -> PreCST e s a
liftIO (IO () -> CST s ()) -> IO () -> CST s ()
forall a b. (a -> b) -> a -> b
$ String -> WithNameSupply AttrC -> IO ()
forall a. Binary a => String -> a -> IO ()
putBinFileWithDict String
preCompFile (AttrC -> WithNameSupply AttrC
forall a. a -> WithNameSupply a
WithNameSupply AttrC
cheader)
Bool
keep <- (SwitchBoard -> Bool) -> PreCST SwitchBoard s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
keepSB
Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keep (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
String -> CST s ()
forall e s. String -> PreCST e s ()
removeFileCIO String
preprocFile
() -> CST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
tracePreproc :: String -> CST s ()
tracePreproc String
cmd = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
String
"Invoking cpp as `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n"
data WithNameSupply a = WithNameSupply a
instance Binary a => Binary (WithNameSupply a) where
put_ :: BinHandle -> WithNameSupply a -> IO ()
put_ BinHandle
bh (WithNameSupply a
x) = do
BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
x
Name
nameSupply <- IO Name
saveRootNameSupply
BinHandle -> Name -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Name
nameSupply
get :: BinHandle -> IO (WithNameSupply a)
get BinHandle
bh = do
a
x <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Name
nameSupply <- BinHandle -> IO Name
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Name -> IO ()
restoreRootNameSupply Name
nameSupply
WithNameSupply a -> IO (WithNameSupply a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> WithNameSupply a
forall a. a -> WithNameSupply a
WithNameSupply a
x)