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