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
$c== :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
/= :: 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
$c== :: DumpType -> DumpType -> Bool
== :: DumpType -> DumpType -> Bool
$c/= :: DumpType -> DumpType -> Bool
/= :: 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 :: forall s. [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 :: forall s. 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 :: forall s a. [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 -> PreCST SwitchBoard s a
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (ExitCode -> PreCST SwitchBoard s a)
-> ExitCode -> PreCST SwitchBoard s a
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 Flag -> [Flag] -> Bool
forall a. Eq a => a -> [a] -> 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
preCompFile <- (SwitchBoard -> Maybe String) -> CST s (Maybe String)
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Maybe String
preCompSB
unless (preCompFile==Nothing) $
preCompileHeader headerFile (fromJust preCompFile)
`fatalsHandledBy` ioErrorHandler
let bndFileWithoutSuffix = String -> String
stripSuffix String
bndFile
unless (null bndFile) $ do
computeOutputName bndFileWithoutSuffix
process headerFile preCompFile bndFileWithoutSuffix
`fatalsHandledBy` ioErrorHandler
where
atMostOne :: [a] -> [a]
atMostOne = (([a] -> a -> [a]) -> [a] -> [a] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
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
name <- PreCST e s String
forall e s. PreCST e s String
getProgNameCIO
putStrCIO $
name ++ ": " ++ ioeGetErrorString ioerr ++ "\n"
exitWithCIO $ ExitFailure 1
help :: CST s ()
help :: forall s. CST s ()
help = do
(version, copyright, disclaimer) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
putStrCIO (usageInfo (header version copyright disclaimer) options)
putStrCIO trailer
processOpt :: Flag -> CST s ()
processOpt :: forall s. 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
(version, _, _) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
putStrCIO (version ++ "\n")
processOpt (Error String
msg ) = String -> CST s ()
forall s. String -> CST s ()
abort String
msg
abort :: String -> CST s ()
abort :: forall s. String -> CST s ()
abort String
msg = do
Handle -> String -> PreCST SwitchBoard s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrLnCIO Handle
stderr String
msg
Handle -> String -> PreCST SwitchBoard s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr String
errTrailer
String -> PreCST SwitchBoard s ()
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
output <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
outDir <- getSwitch outDirSB
let dir = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outDir Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output then String -> String
dirname String
bndFileNoSuffix
else if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outDir then String -> String
dirname String
output
else String
outDir
let base = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output then String -> String
basename String
bndFileNoSuffix
else String -> String
basename String
output
setSwitch $ \SwitchBoard
sb -> SwitchBoard
sb {
outputSB = dir `addPath` base,
outDirSB = 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" 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 = cppOptsSB sb ++ opts}
setCPP :: FilePath -> CST s ()
setCPP :: forall s. 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 = fname}
addHPaths :: [FilePath] -> CST s ()
addHPaths :: forall s. [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 = paths ++ hpathsSB sb}
setDump :: DumpType -> CST s ()
setDump :: forall s. 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 = 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 = 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 = 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 = True}
setKeep :: CST s ()
setKeep :: forall s. 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 = True}
setInclude :: String -> CST s ()
setInclude :: forall s. 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 = fp ++ (chiPathSB sb)}
setOutput :: FilePath -> CST s ()
setOutput :: forall s. String -> CST s ()
setOutput String
fname = do
Bool -> PreCST SwitchBoard s () -> PreCST SwitchBoard 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) (PreCST SwitchBoard s () -> PreCST SwitchBoard s ())
-> PreCST SwitchBoard s () -> PreCST SwitchBoard s ()
forall a b. (a -> b) -> a -> b
$
[String] -> PreCST SwitchBoard s ()
forall s a. [String] -> CST s a
raiseErrs [String
"Output file should end in .hs!\n"]
(SwitchBoard -> SwitchBoard) -> PreCST SwitchBoard s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> PreCST SwitchBoard s ())
-> (SwitchBoard -> SwitchBoard) -> PreCST SwitchBoard s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {outputSB = stripSuffix fname}
setOutDir :: FilePath -> CST s ()
setOutDir :: forall s. 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 = 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 = fname}
setPreComp :: FilePath -> CST s ()
setPreComp :: forall s. 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 = Just fname }
setLockFun :: String -> CST s ()
setLockFun :: forall s. 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 = Just 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
(chsMod , warnmsgs) <- String -> CST s (CHSModule, String)
forall s. String -> CST s (CHSModule, String)
loadCHS String
bndFile
putStrCIO warnmsgs
chsMod <- case skipToLangPragma 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
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
let outFileBase = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outFName then String -> String
basename String
bndFile else String
outFName
let ppFile = String
outFileBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chssuffix
cpp <- getSwitch cppSB
cppOpts <- getSwitch cppOptsSB
let args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
cppoptsdef, String
headerFile, String
bndFile]
tracePreproc (unwords (cpp:args))
exitCode <- liftIO $ do
ppHnd <- openFile ppFile WriteMode
process <- runProcess cpp args
Nothing Nothing Nothing (Just ppHnd) Nothing
waitForProcess process
case exitCode of
ExitFailure Int
_ -> String -> PreCST SwitchBoard s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing chs file"
ExitCode
_ -> PreCST SwitchBoard s ()
forall e s. PreCST e s ()
nop
(chsMod , warnmsgs) <- loadCHS ppFile
keep <- getSwitch keepSB
unless keep $
removeFileCIO ppFile
case skipToLangPragma chsMod of Just CHSModule
chsMod -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod
traceCHSDump chsMod
(header, strippedCHSMod, warnmsgs) <- genHeader chsMod
putStrCIO warnmsgs
pcFileExists <- maybe (return False) doesFileExistCIO preCompFile
cheader <- if null header && pcFileExists then do
traceReadPrecomp (fromJust preCompFile)
WithNameSupply cheader <- liftIO $ getBinFileWithDict (fromJust preCompFile)
return cheader
else do
outFName <- getSwitch outputSB
let newHeaderFile = String
outFName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsuffix
let preprocFile = String -> String
basename String
newHeaderFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isuffix
newHeader <- openFileCIO newHeaderFile WriteMode
unless (null headerFile) $
hPutStrLnCIO newHeader $ "#include \"" ++ headerFile ++ "\""
mapM (hPutStrCIO newHeader) header
hCloseCIO newHeader
setHeader newHeaderFile
cpp <- getSwitch cppSB
cppOpts <- getSwitch cppOptsSB
let args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
newHeaderFile]
tracePreproc (unwords (cpp:args))
exitCode <- liftIO $ do
preprocHnd <- openFile preprocFile WriteMode
process <- runProcess cpp args
Nothing Nothing Nothing (Just preprocHnd) Nothing
waitForProcess process
case exitCode of
ExitFailure Int
_ -> String -> PreCST SwitchBoard s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing custom header file"
ExitCode
_ -> PreCST SwitchBoard s ()
forall e s. PreCST e s ()
nop
(cheader, warnmsgs) <- loadAttrC preprocFile
putStrCIO warnmsgs
keep <- getSwitch keepSB
unless keep $
removeFileCIO preprocFile
return cheader
(hsMod, chi, warnmsgs) <- expandHooks cheader strippedCHSMod
putStrCIO warnmsgs
outFName <- getSwitch outputSB
let hsFile = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outFName then String -> String
basename String
bndFile else String
outFName
dumpCHS hsFile hsMod True
dumpCHI hsFile 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
flag <- (Traces -> Bool) -> CST s Bool
forall s. (Traces -> Bool) -> CST s Bool
traceSet Traces -> Bool
dumpCHSSW
when flag $
(do
putStrCIO ("...dumping CHS to `" ++ chsName
++ "'...\n")
dumpCHS chsName mod 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
pcFileExists <- String -> PreCST SwitchBoard s Bool
forall e s. String -> PreCST e s Bool
doesFileExistCIO String
preCompFile
unless pcFileExists $ do
hpaths <- getSwitch hpathsSB
realHeaderFile <- headerFile `fileFindInCIO` hpaths
cpp <- getSwitch cppSB
cppOpts <- getSwitch cppOptsSB
let args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
realHeaderFile]
tracePreproc (unwords (cpp:args))
exitCode <- liftIO $ do
preprocHnd <- openFile preprocFile WriteMode
process <- runProcess cpp args
Nothing Nothing Nothing (Just preprocHnd) Nothing
waitForProcess process
case exitCode of
ExitFailure Int
_ -> String -> PreCST SwitchBoard s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing"
ExitCode
_ -> PreCST SwitchBoard s ()
forall e s. PreCST e s ()
nop
(cheader, warnmsgs) <- loadAttrC preprocFile
putStrCIO warnmsgs
liftIO $ putBinFileWithDict preCompFile (WithNameSupply cheader)
keep <- getSwitch keepSB
unless keep $
removeFileCIO preprocFile
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
nameSupply <- IO Name
saveRootNameSupply
put_ bh nameSupply
get :: BinHandle -> IO (WithNameSupply a)
get BinHandle
bh = do
x <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
nameSupply <- get bh
restoreRootNameSupply nameSupply
return (WithNameSupply x)