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