diff --git a/c2hs/base/general/UNames.hs b/c2hs/base/general/UNames.hs --- a/c2hs/base/general/UNames.hs +++ b/c2hs/base/general/UNames.hs @@ -52,7 +52,7 @@ module UNames (NameSupply, Name, rootSupply, splitSupply, names, - saveRootNameSupply, restoreRootNameSupply) + saveRootNameSupply, restoreRootNameSupply, unsafeResetRootNameSupply) where import Control.Monad (when) @@ -136,6 +136,12 @@ when (prev > 1) (error "UName: root name supply used before restoring") writeIORef ref val +-- Resets the root name supply +-- you must not do this unless you are done with all the names +unsafeResetRootNameSupply :: IO () +unsafeResetRootNameSupply = + case rootSupply of + NameSupply ref -> writeIORef ref 1 {-! for Name derive : GhcBinary !-} {-* Generated by DrIFT : Look, but Don't Touch. *-} diff --git a/c2hs/toplevel/Gtk2HsC2Hs.hs b/c2hs/toplevel/Gtk2HsC2Hs.hs new file mode 100644 --- /dev/null +++ b/c2hs/toplevel/Gtk2HsC2Hs.hs @@ -0,0 +1,729 @@ +-- C -> Haskell Compiler: main module +-- +-- Author : Manuel M T Chakravarty +-- Derived: 12 August 99 +-- +-- Version $Revision: 1.6 $ from $Date: 2005/07/03 14:58:16 $ +-- +-- Copyright (c) [1999..2004] Manuel M T Chakravarty +-- +-- This file is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This file is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This is the main module of the compiler. It sets the version, processes +-- the command line arguments, and controls the compilation process. +-- +-- Originally, derived from `Main.hs' of the Nepal Compiler. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- language: Haskell 98 +-- +-- Usage: +-- ------ +-- +-- c2hs [ option... ] header-file binding-file +-- +-- The compiler is supposed to emit a Haskell program that expands all hooks +-- in the given binding file. +-- +-- File name suffix: +-- ----------------- +-- +-- Note: These also depend on suffixes defined in the compiler proper. +-- +-- .h C header file +-- .i pre-processeed C header file +-- .hs Haskell file +-- .chs Haskell file with C->Haskell hooks (binding file) +-- .chi C->Haskell interface file +-- +-- Options: +-- -------- +-- +-- -C CPPOPTS +-- --cppopts=CPPOPTS +-- Pass the additional options CPPOPTS to the C preprocessor. +-- +-- Repeated occurences accumulate. +-- +-- -c CPP +-- --cpp=CPP +-- Use the executable CPP to invoke CPP. +-- +-- In the case of repeated occurences, the last takes effect. +-- +-- -d TYPE +-- --dump=TYPE +-- Dump intermediate representation: +-- +-- + if TYPE is `trace', trace the compiler phases (to stderr) +-- + if TYPE is `genbind', trace binding generation (to stderr) +-- + if TYPE is `ctrav', trace C declaration traversal (to stderr) +-- + if TYPE is `chs', dump the binding file (insert `.dump' into the +-- file name to avoid overwriting the original file) +-- +-- -h, -? +-- --help +-- Dump brief usage information to stderr. +-- +-- -i DIRS +-- --include=DIRS +-- Search the colon separated list of directories DIRS when searching +-- for .chi files. +-- +-- -k +-- --keep +-- Keep the intermediate file that contains the pre-processed C header +-- (it carries the suffix `.i'). +-- +-- -o FILE +-- --output=FILE +-- Place output in file FILE. +-- +-- If `-o' is not specified, the default is to put the output for +-- `source.chs' in `source.hs' in the same directory that contains the +-- binding file. If specified, the emitted C header file is put into +-- the same directory as the output file. The same holds for +-- C->Haskell interface file. All generated files also share the +-- basename. +-- +-- -t PATH +-- --output-dir=PATH +-- Place generated files in the directory PATH. +-- +-- If this option as well as the `-o' option is given, the basename of +-- the file specified with `-o' is put in the directory specified with +-- `-t'. +-- +-- -v, +-- --version +-- Print (on standard error output) the version and copyright +-- information of the compiler (before doing anything else). +-- +-- -p FILE +-- --precomp=FILE +-- Use or generate a precompiled header. If a header file is +-- given write a condensed version of the header file into +-- FILE. If a binding file is given that does not contain any C +-- declarations itself, use the condensed information in FILE +-- to generate the binding. Using a precompiled header file will +-- significantly speed up the translation of a binding module. +-- +-- --old-ffi [=yes|=no] +-- Generate hooks using pre-standard FFI libraries. This currently +-- affects only call hooks where instead of `Addr' types +-- `Ptr ' is used. +-- +-- --lock=NAME +-- Wrap each foreign function call in the function NAME. This +-- function is usually a function that acquires a lock for +-- the memory region that the called function is about to access. +-- A wrap function can also be specificed within the file in the +-- context hook, in which case it overrides the command line function. +-- The wrapper function can be omitted on a call-by-call basis by +-- using the nolock option in the call hook. +-- +--- TODO ---------------------------------------------------------------------- +-- + +module Gtk2HsC2Hs (c2hsMain) +where + +-- standard libraries +import Data.List (isPrefixOf) +import System.IO (openFile) +import System.Process (runProcess, waitForProcess) +import Control.Monad (when, unless, mapM) +import Data.Maybe (fromJust) + +-- base libraries +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) + +-- c2hs modules +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) + + +-- wrapper running the compiler +-- ============================ + +c2hsMain :: [String] -> IO () +c2hsMain = runC2HS (version, copyright, disclaimer) . compile + + +-- option handling +-- =============== + +-- header is output in case of help, before the descriptions of the options; +-- errTrailer is output after an error message +-- +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" + +-- supported option types +-- +data Flag = CPPOpts String -- additional options for C preprocessor + | CPP String -- program name of C preprocessor + | Dump DumpType -- dump internal information + | Help -- print brief usage information + | Keep -- keep the .i file + | Include String -- list of directories to search .chi files + | Output String -- file where the generated file should go + | OutDir String -- directory where generates files should go + | PreComp String -- write or read a precompiled header + | LockFun String -- wrap each function call in this function + | Version -- print version information on stderr + | Error String -- error occured during processing of options + deriving Eq + +data DumpType = Trace -- compiler trace + | GenBind -- trace `GenBind' + | CTrav -- trace `CTrav' + | CHS -- dump binding file + deriving Eq + +-- option description suitable for `GetOpt' +-- +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"] + +-- convert argument of `Dump' option +-- +dumpArg :: String -> Flag +dumpArg "trace" = Dump Trace +dumpArg "genbind" = Dump GenBind +dumpArg "ctrav" = Dump CTrav +dumpArg "chs" = Dump CHS +dumpArg _ = Error "Illegal dump type." + +-- main process (set up base configuration, analyse command line, and execute +-- compilation process) +-- +-- * Exceptions are caught and reported +-- +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" + -- + -- exception handler + -- + failureHandler err = + do + let msg = ioeGetErrorString err + fnMsg = case ioeGetFileName err of + Nothing -> "" + Just s -> " (file: `" ++ s ++ "')" + hPutStrLnCIO stderr (msg ++ fnMsg) + exitWithCIO $ ExitFailure 1 + +-- set up base configuration +-- +setup :: CST s () +setup = do + setCPP cpp + addCPPOpts cppopts + addHPaths hpaths + +-- output error message +-- +raiseErrs :: [String] -> CST s a +raiseErrs errs = do + hPutStrCIO stderr (concat errs) + hPutStrCIO stderr errTrailer + exitWithCIO $ ExitFailure 1 + +-- Process tasks +-- ------------- + +-- execute the compilation task +-- +-- * if `Help' is present, emit the help message and ignore the rest +-- * if `Version' is present, do it first (and only once) +-- * actual compilation is only invoked if we have one or two extra arguments +-- (otherwise, it is just skipped) +-- +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 + +-- emit help message +-- +help :: CST s () +help = do + (version, copyright, disclaimer) <- getId + putStrCIO (usageInfo (header version copyright disclaimer) options) + putStrCIO trailer + +-- process an option +-- +-- * `Help' cannot occur +-- +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 + +-- emit error message and raise an error +-- +abort :: String -> CST s () +abort msg = do + hPutStrLnCIO stderr msg + hPutStrCIO stderr errTrailer + fatal "Error in command line options" + +-- Compute the base name for all generated files (Haskell, C header, and .chi +-- file) +-- +-- * The result is available from the `outputSB' switch +-- +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 + } + + +-- set switches +-- ------------ + +-- set the options for the C proprocessor +-- +-- * any header search path that is set with `-IDIR' is also added to +-- `hpathsSB' +-- +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} + +-- set the program name of the C proprocessor +-- +setCPP :: FilePath -> CST s () +setCPP fname = setSwitch $ \sb -> sb {cppSB = fname} + +-- add header file search paths +-- +addHPaths :: [FilePath] -> CST s () +addHPaths paths = setSwitch $ \sb -> sb {hpathsSB = paths ++ hpathsSB sb} + +-- set the given dump option +-- +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} + +-- set flag to keep the pre-processed header file +-- +setKeep :: CST s () +setKeep = setSwitch $ \sb -> sb {keepSB = True} + +-- set the search directories for .chi files +-- +-- * Several -i flags are accumulated. Later paths have higher priority. +-- +-- * The current directory is always searched last because it is the +-- standard value in the compiler state. +-- +setInclude :: String -> CST s () +setInclude str = do + let fp = splitSearchPath str + setSwitch $ \sb -> sb {chiPathSB = fp ++ (chiPathSB sb)} + +-- set the output file name +-- +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} + +-- set the output directory +-- +setOutDir :: FilePath -> CST s () +setOutDir fname = setSwitch $ \sb -> sb {outDirSB = fname} + +-- set the name of the generated header file +-- +setHeader :: FilePath -> CST s () +setHeader fname = setSwitch $ \sb -> sb {headerSB = fname} + +-- set the file name in which the precompiled header ends up +-- +setPreComp :: FilePath -> CST s () +setPreComp fname = setSwitch $ \sb -> sb { preCompSB = Just fname } + +-- set the name of the wrapper function that acquires a lock +-- +setLockFun :: String -> CST s () +setLockFun name = setSwitch $ \sb -> sb { lockFunSB = Just name } + +-- compilation process +-- ------------------- + +-- read the binding module, construct a header, run it through CPP, read it, +-- and finally generate the Haskell target +-- +-- * the header file name (first argument) may be empty; otherwise, it already +-- contains the right suffix +-- +-- * the binding file name has been stripped of the .chs suffix +-- +process :: FilePath -> Maybe FilePath -> FilePath -> CST s () +process headerFile preCompFile bndFileStripped = + do + -- load the Haskell binding module, any imported module with CHI information is + -- only inserted as file name, the content of the CHI modules is inserted below + -- using 'loadAllCHI'. This ensures that we don't look for a CHI file that is + -- commented out using an #ifdef + -- + (chsMod , warnmsgs) <- loadCHS bndFile + + putStrCIO warnmsgs + + -- check if a CPP language pragma is present and, if so, run CPP on the file + -- and re-read it + 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 + -- + -- extract CPP and inline-C embedded in the .chs file (all CPP and + -- inline-C fragments are removed from the .chs tree and conditionals are + -- replaced by structured conditionals) + -- + (header, strippedCHSMod, warnmsgs) <- genHeader chsMod + putStrCIO warnmsgs + + pcFileExists <- maybe (return False) doesFileExistCIO preCompFile + + cheader <- if null header && pcFileExists then do + -- there are no cpp directives in the .chs file, use the precompiled header + -- + traceReadPrecomp (fromJust preCompFile) + WithNameSupply cheader <- liftIO $ getBinFileWithDict (fromJust preCompFile) + return cheader + + else do + -- + -- create new header file, make it #include `headerFile', and emit + -- CPP and inline-C of .chs file into the new header + -- + 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 + -- + -- run C preprocessor over the header + -- + 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 + -- + -- load and analyse the C header file + -- + (cheader, warnmsgs) <- loadAttrC preprocFile + putStrCIO warnmsgs + -- + -- remove the custom header and the pre-processed header + -- + keep <- getSwitch keepSB + unless keep $ + removeFileCIO preprocFile + + return cheader + + -- + -- expand binding hooks into plain Haskell + -- + (hsMod, chi, warnmsgs) <- expandHooks cheader strippedCHSMod + putStrCIO warnmsgs + -- + -- output the result + -- + outFName <- getSwitch outputSB + let hsFile = if null outFName then basename bndFile else outFName + dumpCHS hsFile hsMod True + dumpCHI hsFile chi -- different suffix will be appended + + 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 + + -- + -- run C preprocessor over the header + -- + 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 + + -- + -- load and analyse the C header file + -- + (cheader, warnmsgs) <- loadAttrC preprocFile + putStrCIO warnmsgs + + -- + -- save the attributed C to disk + -- + liftIO $ putBinFileWithDict preCompFile (WithNameSupply cheader) + + -- + -- remove the pre-processed header + -- + keep <- getSwitch keepSB + unless keep $ + removeFileCIO preprocFile + + return () + where + tracePreproc cmd = putTraceStr tracePhasesSW $ + "Invoking cpp as `" ++ cmd ++ "'...\n" + + +-- dummy type so we can save and restore the name supply +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) diff --git a/c2hs/toplevel/Main.hs b/c2hs/toplevel/Main.hs deleted file mode 100644 --- a/c2hs/toplevel/Main.hs +++ /dev/null @@ -1,732 +0,0 @@ --- C -> Haskell Compiler: main module --- --- Author : Manuel M T Chakravarty --- Derived: 12 August 99 --- --- Version $Revision: 1.6 $ from $Date: 2005/07/03 14:58:16 $ --- --- Copyright (c) [1999..2004] Manuel M T Chakravarty --- --- This file is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- This file is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- ---- DESCRIPTION --------------------------------------------------------------- --- --- This is the main module of the compiler. It sets the version, processes --- the command line arguments, and controls the compilation process. --- --- Originally, derived from `Main.hs' of the Nepal Compiler. --- ---- DOCU ---------------------------------------------------------------------- --- --- language: Haskell 98 --- --- Usage: --- ------ --- --- c2hs [ option... ] header-file binding-file --- --- The compiler is supposed to emit a Haskell program that expands all hooks --- in the given binding file. --- --- File name suffix: --- ----------------- --- --- Note: These also depend on suffixes defined in the compiler proper. --- --- .h C header file --- .i pre-processeed C header file --- .hs Haskell file --- .chs Haskell file with C->Haskell hooks (binding file) --- .chi C->Haskell interface file --- --- Options: --- -------- --- --- -C CPPOPTS --- --cppopts=CPPOPTS --- Pass the additional options CPPOPTS to the C preprocessor. --- --- Repeated occurences accumulate. --- --- -c CPP --- --cpp=CPP --- Use the executable CPP to invoke CPP. --- --- In the case of repeated occurences, the last takes effect. --- --- -d TYPE --- --dump=TYPE --- Dump intermediate representation: --- --- + if TYPE is `trace', trace the compiler phases (to stderr) --- + if TYPE is `genbind', trace binding generation (to stderr) --- + if TYPE is `ctrav', trace C declaration traversal (to stderr) --- + if TYPE is `chs', dump the binding file (insert `.dump' into the --- file name to avoid overwriting the original file) --- --- -h, -? --- --help --- Dump brief usage information to stderr. --- --- -i DIRS --- --include=DIRS --- Search the colon separated list of directories DIRS when searching --- for .chi files. --- --- -k --- --keep --- Keep the intermediate file that contains the pre-processed C header --- (it carries the suffix `.i'). --- --- -o FILE --- --output=FILE --- Place output in file FILE. --- --- If `-o' is not specified, the default is to put the output for --- `source.chs' in `source.hs' in the same directory that contains the --- binding file. If specified, the emitted C header file is put into --- the same directory as the output file. The same holds for --- C->Haskell interface file. All generated files also share the --- basename. --- --- -t PATH --- --output-dir=PATH --- Place generated files in the directory PATH. --- --- If this option as well as the `-o' option is given, the basename of --- the file specified with `-o' is put in the directory specified with --- `-t'. --- --- -v, --- --version --- Print (on standard error output) the version and copyright --- information of the compiler (before doing anything else). --- --- -p FILE --- --precomp=FILE --- Use or generate a precompiled header. If a header file is --- given write a condensed version of the header file into --- FILE. If a binding file is given that does not contain any C --- declarations itself, use the condensed information in FILE --- to generate the binding. Using a precompiled header file will --- significantly speed up the translation of a binding module. --- --- --old-ffi [=yes|=no] --- Generate hooks using pre-standard FFI libraries. This currently --- affects only call hooks where instead of `Addr' types --- `Ptr ' is used. --- --- --lock=NAME --- Wrap each foreign function call in the function NAME. This --- function is usually a function that acquires a lock for --- the memory region that the called function is about to access. --- A wrap function can also be specificed within the file in the --- context hook, in which case it overrides the command line function. --- The wrapper function can be omitted on a call-by-call basis by --- using the nolock option in the call hook. --- ---- TODO ---------------------------------------------------------------------- --- - -module Main (main) -where - --- standard libraries -import Data.List (isPrefixOf) -import System.IO (openFile) -import System.Process (runProcess, waitForProcess) -import Control.Monad (when, unless, mapM) -import Data.Maybe (fromJust) - --- base libraries -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) - --- c2hs modules -import C2HSState (CST, nop, runC2HS, fatal, fatalsHandledBy, getId, - ExitCode(..), stderr, IOMode(..), putStrCIO, hPutStrCIO, - hPutStrLnCIO, exitWithCIO, getArgsCIO, 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) - - --- wrapper running the compiler --- ============================ - -main :: IO () -main = runC2HS (version, copyright, disclaimer) compile - - --- option handling --- =============== - --- header is output in case of help, before the descriptions of the options; --- errTrailer is output after an error message --- -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" - --- supported option types --- -data Flag = CPPOpts String -- additional options for C preprocessor - | CPP String -- program name of C preprocessor - | Dump DumpType -- dump internal information - | Help -- print brief usage information - | Keep -- keep the .i file - | Include String -- list of directories to search .chi files - | Output String -- file where the generated file should go - | OutDir String -- directory where generates files should go - | PreComp String -- write or read a precompiled header - | LockFun String -- wrap each function call in this function - | Version -- print version information on stderr - | Error String -- error occured during processing of options - deriving Eq - -data DumpType = Trace -- compiler trace - | GenBind -- trace `GenBind' - | CTrav -- trace `CTrav' - | CHS -- dump binding file - deriving Eq - --- option description suitable for `GetOpt' --- -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"] - --- convert argument of `Dump' option --- -dumpArg :: String -> Flag -dumpArg "trace" = Dump Trace -dumpArg "genbind" = Dump GenBind -dumpArg "ctrav" = Dump CTrav -dumpArg "chs" = Dump CHS -dumpArg _ = Error "Illegal dump type." - --- main process (set up base configuration, analyse command line, and execute --- compilation process) --- --- * Exceptions are caught and reported --- -compile :: CST s () -compile = - do - setup - cmdLine <- getArgsCIO - 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 = do - execute opts args - `fatalsHandledBy` failureHandler - exitWithCIO ExitSuccess - -- - 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" - -- - -- exception handler - -- - failureHandler err = - do - let msg = ioeGetErrorString err - fnMsg = case ioeGetFileName err of - Nothing -> "" - Just s -> " (file: `" ++ s ++ "')" - hPutStrLnCIO stderr (msg ++ fnMsg) - exitWithCIO $ ExitFailure 1 - --- set up base configuration --- -setup :: CST s () -setup = do - setCPP cpp - addCPPOpts cppopts - addHPaths hpaths - --- output error message --- -raiseErrs :: [String] -> CST s a -raiseErrs errs = do - hPutStrCIO stderr (concat errs) - hPutStrCIO stderr errTrailer - exitWithCIO $ ExitFailure 1 - --- Process tasks --- ------------- - --- execute the compilation task --- --- * if `Help' is present, emit the help message and ignore the rest --- * if `Version' is present, do it first (and only once) --- * actual compilation is only invoked if we have one or two extra arguments --- (otherwise, it is just skipped) --- -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 - --- emit help message --- -help :: CST s () -help = do - (version, copyright, disclaimer) <- getId - putStrCIO (usageInfo (header version copyright disclaimer) options) - putStrCIO trailer - --- process an option --- --- * `Help' cannot occur --- -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 - --- emit error message and raise an error --- -abort :: String -> CST s () -abort msg = do - hPutStrLnCIO stderr msg - hPutStrCIO stderr errTrailer - fatal "Error in command line options" - --- Compute the base name for all generated files (Haskell, C header, and .chi --- file) --- --- * The result is available from the `outputSB' switch --- -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 - } - - --- set switches --- ------------ - --- set the options for the C proprocessor --- --- * any header search path that is set with `-IDIR' is also added to --- `hpathsSB' --- -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} - --- set the program name of the C proprocessor --- -setCPP :: FilePath -> CST s () -setCPP fname = setSwitch $ \sb -> sb {cppSB = fname} - --- add header file search paths --- -addHPaths :: [FilePath] -> CST s () -addHPaths paths = setSwitch $ \sb -> sb {hpathsSB = paths ++ hpathsSB sb} - --- set the given dump option --- -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} - --- set flag to keep the pre-processed header file --- -setKeep :: CST s () -setKeep = setSwitch $ \sb -> sb {keepSB = True} - --- set the search directories for .chi files --- --- * Several -i flags are accumulated. Later paths have higher priority. --- --- * The current directory is always searched last because it is the --- standard value in the compiler state. --- -setInclude :: String -> CST s () -setInclude str = do - let fp = splitSearchPath str - setSwitch $ \sb -> sb {chiPathSB = fp ++ (chiPathSB sb)} - --- set the output file name --- -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} - --- set the output directory --- -setOutDir :: FilePath -> CST s () -setOutDir fname = setSwitch $ \sb -> sb {outDirSB = fname} - --- set the name of the generated header file --- -setHeader :: FilePath -> CST s () -setHeader fname = setSwitch $ \sb -> sb {headerSB = fname} - --- set the file name in which the precompiled header ends up --- -setPreComp :: FilePath -> CST s () -setPreComp fname = setSwitch $ \sb -> sb { preCompSB = Just fname } - --- set the name of the wrapper function that acquires a lock --- -setLockFun :: String -> CST s () -setLockFun name = setSwitch $ \sb -> sb { lockFunSB = Just name } - --- compilation process --- ------------------- - --- read the binding module, construct a header, run it through CPP, read it, --- and finally generate the Haskell target --- --- * the header file name (first argument) may be empty; otherwise, it already --- contains the right suffix --- --- * the binding file name has been stripped of the .chs suffix --- -process :: FilePath -> Maybe FilePath -> FilePath -> CST s () -process headerFile preCompFile bndFileStripped = - do - -- load the Haskell binding module, any imported module with CHI information is - -- only inserted as file name, the content of the CHI modules is inserted below - -- using 'loadAllCHI'. This ensures that we don't look for a CHI file that is - -- commented out using an #ifdef - -- - (chsMod , warnmsgs) <- loadCHS bndFile - - putStrCIO warnmsgs - - -- check if a CPP language pragma is present and, if so, run CPP on the file - -- and re-read it - 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 - -- - -- extract CPP and inline-C embedded in the .chs file (all CPP and - -- inline-C fragments are removed from the .chs tree and conditionals are - -- replaced by structured conditionals) - -- - (header, strippedCHSMod, warnmsgs) <- genHeader chsMod - putStrCIO warnmsgs - - pcFileExists <- maybe (return False) doesFileExistCIO preCompFile - - cheader <- if null header && pcFileExists then do - -- there are no cpp directives in the .chs file, use the precompiled header - -- - traceReadPrecomp (fromJust preCompFile) - WithNameSupply cheader <- liftIO $ getBinFileWithDict (fromJust preCompFile) - return cheader - - else do - -- - -- create new header file, make it #include `headerFile', and emit - -- CPP and inline-C of .chs file into the new header - -- - 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 - -- - -- run C preprocessor over the header - -- - 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 - -- - -- load and analyse the C header file - -- - (cheader, warnmsgs) <- loadAttrC preprocFile - putStrCIO warnmsgs - -- - -- remove the custom header and the pre-processed header - -- - keep <- getSwitch keepSB - unless keep $ - removeFileCIO preprocFile - - return cheader - - -- - -- expand binding hooks into plain Haskell - -- - (hsMod, chi, warnmsgs) <- expandHooks cheader strippedCHSMod - putStrCIO warnmsgs - -- - -- output the result - -- - outFName <- getSwitch outputSB - let hsFile = if null outFName then basename bndFile else outFName - dumpCHS hsFile hsMod True - dumpCHI hsFile chi -- different suffix will be appended - - 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 - - -- - -- run C preprocessor over the header - -- - 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 - - -- - -- load and analyse the C header file - -- - (cheader, warnmsgs) <- loadAttrC preprocFile - putStrCIO warnmsgs - - -- - -- save the attributed C to disk - -- - liftIO $ putBinFileWithDict preCompFile (WithNameSupply cheader) - - -- - -- remove the pre-processed header - -- - keep <- getSwitch keepSB - unless keep $ - removeFileCIO preprocFile - - return () - where - tracePreproc cmd = putTraceStr tracePhasesSW $ - "Invoking cpp as `" ++ cmd ++ "'...\n" - - --- dummy type so we can save and restore the name supply -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) diff --git a/callbackGen/HookGenerator.hs b/callbackGen/HookGenerator.hs --- a/callbackGen/HookGenerator.hs +++ b/callbackGen/HookGenerator.hs @@ -1,12 +1,11 @@ -{-# OPTIONS -cpp #-} +{-# LANGUAGE CPP #-} -- HookGenerator.hs -*-haskell-*- -- Takes a type list of possible hooks from the GTK+ distribution and produces -- Haskell functions to connect to these callbacks. -module Main(main) where +module HookGenerator(hookGen) where import Data.Char (showLitChar) import Data.List (nub, isPrefixOf) -import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(..)) import System.IO (stderr, hPutStr) import Paths_gtk2hs_buildtools (getDataFileName) @@ -512,8 +511,8 @@ " a module to be imported into the template file\n" exitWith $ ExitFailure 1 -main = do - args <- getArgs +hookGen :: [String] -> IO String +hookGen args = do let showHelp = not (null (filter ("-h" `isPrefixOf`) args++ filter ("--help" `isPrefixOf`) args)) || null args if showHelp then usage else do @@ -529,7 +528,7 @@ content <- readFile typesFile let sigs = parseSignatures content template <- readFile templateFile - putStr $ + return $ templateSubstitute template (\var -> case var of "MODULE_NAME" -> ss outModuleName diff --git a/exe/gtk2hsC2hsMain.hs b/exe/gtk2hsC2hsMain.hs new file mode 100644 --- /dev/null +++ b/exe/gtk2hsC2hsMain.hs @@ -0,0 +1,4 @@ +module Main (main) where +import System.Environment (getArgs) +import Gtk2HsC2Hs (c2hsMain) +main = getArgs >>= c2hsMain diff --git a/exe/gtk2hsHookGeneratorMain.hs b/exe/gtk2hsHookGeneratorMain.hs new file mode 100644 --- /dev/null +++ b/exe/gtk2hsHookGeneratorMain.hs @@ -0,0 +1,4 @@ +module Main (main) where +import System.Environment (getArgs) +import HookGenerator (hookGen) +main = getArgs >>= hookGen >>= putStr diff --git a/exe/gtk2hsTypeGenMain.hs b/exe/gtk2hsTypeGenMain.hs new file mode 100644 --- /dev/null +++ b/exe/gtk2hsTypeGenMain.hs @@ -0,0 +1,4 @@ +module Main (main) where +import System.Environment (getArgs) +import TypeGen (typeGen) +main = getArgs >>= typeGen >>= putStr diff --git a/gtk2hs-buildtools.cabal b/gtk2hs-buildtools.cabal --- a/gtk2hs-buildtools.cabal +++ b/gtk2hs-buildtools.cabal @@ -1,12 +1,12 @@ Name: gtk2hs-buildtools -Version: 0.13.1.0 +Version: 0.13.2.0 License: GPL-2 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Axel Simon, Duncan Coutts, Manuel Chakravaty Maintainer: gtk2hs-devel@lists.sourceforge.net Build-Type: Simple -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Stability: stable homepage: http://projects.haskell.org/gtk2hs/ bug-reports: https://github.com/gtk2hs/gtk2hs/issues @@ -31,98 +31,111 @@ location: https://github.com/gtk2hs/gtk2hs subdir: tools +Flag ClosureSignals + Description: Use the the GClosure-based signals implementation. +-- if ! (arch(sparc) || arch(x86_64) || impl(ghc >= 6.4.1)) +-- Default: False + Library - build-depends: base, + build-depends: base >= 4 && < 5, + process, directory, array, containers, pretty, + filepath, random, Cabal >= 1.24.0.0 && < 1.25, filepath >= 1.3.0.0 && < 1.5, directory >= 1.2.0.0 && < 1.3, containers >= 0.5.5.1 && < 0.6 + if impl(ghc >= 7.7) + build-depends: hashtables + build-tools: alex >= 3.0.1, happy >= 1.18.9 hs-source-dirs: src + hierarchyGen + callbackGen + c2hs/toplevel + c2hs/state + c2hs/gen + c2hs/chs + c2hs/c + c2hs/base/admin + c2hs/base/general + c2hs/base/state + c2hs/base/errors + c2hs/base/syms + c2hs/base/syntax + c-sources: c2hs/toplevel/c2hs_config.c exposed-modules: Gtk2HsSetup + TypeGen + HookGenerator + Gtk2HsC2Hs + other-modules: Paths_gtk2hs_buildtools + -- gtk2hsC2hs Modules + BaseVersion + Config + Errors + Binary + DLists + FastMutInt + FileOps + FNameOps + Map + Position + Set + UNames + CIO + State + StateBase + StateTrans + Attributes + Idents + NameSpaces + Lexers + C + CAST + CAttrs + CBuiltin + CLexer + CNames + CParser + CParserMonad + CPretty + CTokens + CTrav + CHS + CHSLexer + CInfo + GBMonad + GenBind + GenHeader + C2HSState + Switches + C2HSConfig + Version -Flag ClosureSignals - Description: Use the the GClosure-based signals implementation. --- if ! (arch(sparc) || arch(x86_64) || impl(ghc >= 6.4.1)) --- Default: False + default-language: Haskell98 + default-extensions: ForeignFunctionInterface + BangPatterns + if flag(ClosureSignals) + cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL + + if os(darwin) + cpp-options: -D_C2HS_CPP_IS_GCC + else + cpp-options: -D_C2HS_CPP_LANG_SINGLE + Executable gtk2hsTypeGen - main-is: TypeGen.hs - hs-source-dirs: hierarchyGen - other-modules: Paths_gtk2hs_buildtools - build-depends: base + main-is: gtk2hsTypeGenMain.hs + hs-source-dirs: exe + build-depends: base, gtk2hs-buildtools + default-language: Haskell98 Executable gtk2hsHookGenerator - main-is: HookGenerator.hs - hs-source-dirs: callbackGen - if flag(ClosureSignals) - cpp-options: -DUSE_GCLOSURE_SIGNALS_IMPL - other-modules: Paths_gtk2hs_buildtools - build-depends: base + main-is: gtk2hsHookGeneratorMain.hs + hs-source-dirs: exe + build-depends: base, gtk2hs-buildtools + default-language: Haskell98 Executable gtk2hsC2hs - main-is: Main.hs - build-depends: base >= 4 && < 5, - process, directory, array, containers, pretty, - filepath, random - build-tools: alex >= 3.0.1, happy >= 1.18.9 - other-modules: BaseVersion - Config - Errors - Binary - DLists - FastMutInt - FileOps - FNameOps - Map - Position - Set - UNames - CIO - State - StateBase - StateTrans - Attributes - Idents - NameSpaces - Lexers - C - CAST - CAttrs - CBuiltin - CLexer - CNames - CParser - CParserMonad - CPretty - CTokens - CTrav - CHS - CHSLexer - CInfo - GBMonad - GenBind - GenHeader - C2HSState - Switches - C2HSConfig - Version - hs-source-dirs: c2hs/toplevel - c2hs/state - c2hs/gen - c2hs/chs - c2hs/c - c2hs/base/admin - c2hs/base/general - c2hs/base/state - c2hs/base/errors - c2hs/base/syms - c2hs/base/syntax - c-sources: c2hs/toplevel/c2hs_config.c - if os(darwin) - cpp-options: -D_C2HS_CPP_IS_GCC - else - cpp-options: -D_C2HS_CPP_LANG_SINGLE - extensions: ForeignFunctionInterface - BangPatterns - if impl(ghc >= 7.7) - build-depends: hashtables + main-is: gtk2hsC2hsMain.hs + hs-source-dirs: exe + build-depends: base, gtk2hs-buildtools + default-language: Haskell98 diff --git a/hierarchyGen/TypeGen.hs b/hierarchyGen/TypeGen.hs --- a/hierarchyGen/TypeGen.hs +++ b/hierarchyGen/TypeGen.hs @@ -1,12 +1,11 @@ --- TypeGenerator.hs +-- TypeGen.hs -- Takes a hierarchical list of all objects in GTK+ and produces -- Haskell class that reflect this hierarchy. -module Main (main) where +module TypeGen (typeGen) where import Data.Char (isAlpha, isAlphaNum, toLower, toUpper, isUpper) import Data.List (isPrefixOf) import Control.Monad (when) -import System.Environment (getArgs) import System.Exit (exitWith, ExitCode(..)) import System.IO (stderr, hPutStr) import Paths_gtk2hs_buildtools (getDataFileName) @@ -61,7 +60,7 @@ pFL ps all = pGetObject ps all all pGetObject :: ParserState -> String -> String -> [(ObjectSpec, TypeQuery)] -pGetObject ps@ParserState { onlyTags=tags } txt txt' = +pGetObject ps@ParserState { onlyTags=tags } txt txt' = (if readTag `elem` tags then (:) (spec, specialQuery) else id) $ pFreshLine (ps { hierObjs=spec}) (dropWhile ((/=) '\n') rem''') where @@ -70,10 +69,10 @@ isTagName c = isAlphaNum_ c || c=='-' || c=='.' --to allow tag 'gtk-2.4' (origCName,rem) = span isAlphaNum txt (origHsName,_) = span isAlphaNum txt' - (eqInst,rem') = + (eqInst,rem') = let r = dropWhile isBlank rem in if "noEq" `isPrefixOf` r then (True, drop 4 r) else (False, r) - (defDestr,rem'') = + (defDestr,rem'') = let r = dropWhile isBlank rem' in if "noDestr" `isPrefixOf` r then (True, drop 7 r) else (False, r) (name,specialQuery,rem''') = case (dropWhile isBlank rem'') of @@ -106,9 +105,8 @@ -- start of code generation ------------------------------------------------------------------------------- - -main = do - args <- getArgs +typeGen :: [String] -> IO String +typeGen args = do let showHelp = not (null (filter ("-h" `isPrefixOf`) args++ filter ("--help" `isPrefixOf`) args)) || null args if showHelp then usage else do @@ -159,9 +157,9 @@ let showImport ('*':m ) = ss "{#import " .ss m .ss "#}" . indent 0 showImport m = ss "import " . ss m . indent 0 ----------------------------------------------------------------------------- - -- Write the result to stdout after substituting values into the template file + -- return the result after substituting values into the template file -- - putStr $ + return $ templateSubstitute template (\var -> case var of "MODULE_NAME" -> ss modName @@ -233,18 +231,18 @@ makeUpcast :: String -> [String] -> ShowS makeUpcast rootObject [obj] = id -- no casting for root -makeUpcast rootObject (obj:_:_) = +makeUpcast rootObject (obj:_:_) = indent 0.ss "castTo".ss obj.ss " :: ".ss rootObject.ss "Class obj => obj -> ".ss obj. indent 0.ss "castTo".ss obj.ss " = castTo gType".ss obj.ss " \"".ss obj.ss "\"". indent 0 makeGType :: TypeTable -> [String] -> ShowS makeGType table [obj] = id -- no GType for root -makeGType table (obj:_:_) = +makeGType table (obj:_:_) = indent 0.ss "gType".ss obj.ss " :: GType". indent 0.ss "gType".ss obj.ss " =". indent 1.ss "{# call fun unsafe ". - ss (case lookup obj table of + ss (case lookup obj table of (Just TypeInfo { tiAlternateName = Just get_type_func }) -> get_type_func (Just TypeInfo { tiQueryFunction = cname}) -> @@ -313,7 +311,7 @@ indent 1.ss "unsafeCast".ss rootObject.ss " = ".ss name.ss " . castForeignPtr . un".ss rootObject templateSubstitute :: String -> (String -> ShowS) -> ShowS -templateSubstitute template varSubst = doSubst template +templateSubstitute template varSubst = doSubst template where doSubst [] = id doSubst ('\\':'@':cs) = sc '@' . doSubst cs doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs diff --git a/src/Gtk2HsSetup.hs b/src/Gtk2HsSetup.hs --- a/src/Gtk2HsSetup.hs +++ b/src/Gtk2HsSetup.hs @@ -66,6 +66,10 @@ import Control.Applicative ((<$>)) import Distribution.Simple.Program.Find ( defaultProgramSearchPath ) +import Gtk2HsC2Hs (c2hsMain) +import HookGenerator (hookGen) +import TypeGen (typeGen) +import UNames (unsafeResetRootNameSupply) onDefaultSearchPath f a b = f a b defaultProgramSearchPath libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of @@ -76,6 +80,7 @@ precompFile = "precompchs.bin" gtk2hsUserHooks = simpleUserHooks { + -- hookedPrograms is only included for backwards compatibility with older Setup.hs. hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal], hookedPreProcessors = [("chs", ourC2hs)], confHook = \pd cf -> @@ -244,7 +249,8 @@ ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), dir <- maybe [] importDirs (lookupUnitId (installedPkgs lbi) ipi) ] (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ + unsafeResetRootNameSupply + c2hsMain $ map ("--include=" ++) (outDir:chiDirs) ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] @@ -252,6 +258,7 @@ "--output=" ++ newOutFile, "--precomp=" ++ buildDir lbi precompFile, header, inDir inFile] + return () getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi @@ -289,23 +296,6 @@ -- Generating the type hierarchy and signal callback .hs files. ------------------------------------------------------------------------------ -typeGenProgram :: Program -typeGenProgram = simpleProgram "gtk2hsTypeGen" - -signalGenProgram :: Program -signalGenProgram = simpleProgram "gtk2hsHookGenerator" - -c2hsLocal :: Program -c2hsLocal = (simpleProgram "gtk2hsC2hs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "gtk2hsC2hs --version" gives a string like: - -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004 - case words str of - (_:_:_:ver:_) -> ver - _ -> "" - } - - genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () genSynthezisedFiles verb pd lbi = do cPkgs <- getPkgConfigPackages verb lbi pd @@ -332,22 +322,22 @@ "x-signals-" `isPrefixOf` field, field /= "x-signals-file"] - genFile :: Program -> [ProgArg] -> FilePath -> IO () + genFile :: ([String] -> IO String) -> [ProgArg] -> FilePath -> IO () genFile prog args outFile = do - res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args + res <- prog args rewriteFile outFile res forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $ \(fileTag, f) -> do let tag = reverse (drop 4 (reverse fileTag)) info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.") - genFile typeGenProgram (typeOpts tag) f + genFile typeGen (typeOpts tag) f case lookup "x-signals-file" xList of Nothing -> return () Just f -> do info verb ("Ensuring that callback hooks in "++f++" are up-to-date.") - genFile signalGenProgram signalsOpts f + genFile hookGen signalsOpts f writeFile "gtk2hs_macros.h" $ generateMacros cPkgs @@ -470,7 +460,7 @@ where (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md) --- Check user whether install gtk2hs-buildtools correctly. +-- Included for backwards compatibility with older Setup.hs. checkGtk2hsBuildtools :: [Program] -> IO () checkGtk2hsBuildtools programs = do programInfos <- mapM (\ prog -> do @@ -483,3 +473,18 @@ exitFailure forM_ programInfos $ \ (name, location) -> when (isNothing location) (printError name) + +-- Included for backwards compatibility with older Setup.hs. +typeGenProgram :: Program +typeGenProgram = simpleProgram "gtk2hsTypeGen" + +-- Included for backwards compatibility with older Setup.hs. +signalGenProgram :: Program +signalGenProgram = simpleProgram "gtk2hsHookGenerator" + +-- Included for backwards compatibility with older Setup.hs. +-- We are not going to use this, so reporting the version we will use +c2hsLocal :: Program +c2hsLocal = (simpleProgram "gtk2hsC2hs") { + programFindVersion = \_ _ -> return . Just $ Version [0,13,13] [] + }