--  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 <someOtherType>' 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 :: [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


-- 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 :: String -> String -> String -> String
header 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"

-- 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 Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq

data DumpType = Trace         -- compiler trace
              | GenBind       -- trace `GenBind'
              | CTrav         -- trace `CTrav'
              | CHS           -- dump binding file
              deriving DumpType -> DumpType -> Bool
(DumpType -> DumpType -> Bool)
-> (DumpType -> DumpType -> Bool) -> Eq DumpType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DumpType -> DumpType -> Bool
$c/= :: DumpType -> DumpType -> Bool
== :: DumpType -> DumpType -> Bool
$c== :: DumpType -> DumpType -> Bool
Eq

-- option description suitable for `GetOpt'
--
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"]

-- convert argument of `Dump' option
--
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."

-- main process (set up base configuration, analyse command line, and execute
-- compilation process)
--
--  * Exceptions are caught and reported
--
compile :: [String] -> CST s ()
compile :: [String] -> CST s ()
compile [String]
cmdLine =
  do
    CST s ()
forall s. CST s ()
setup
    case ArgOrder Flag
-> [OptDescr Flag] -> [String] -> ([Flag], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder Flag
forall a. ArgOrder a
RequireOrder [OptDescr Flag]
options [String]
cmdLine of
      ([Flag
Help]   , []  , []) -> [Flag] -> [String] -> CST s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag
Help]    []
      ([Flag
Version], []  , []) -> [Flag] -> [String] -> CST s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag
Version] []
      ([Flag]
opts     , [String]
args, [])
        | [String] -> Bool
properArgs [String]
args -> [Flag] -> [String] -> CST s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag]
opts [String]
args
        | Bool
otherwise       -> [String] -> CST s ()
forall s a. [String] -> CST s a
raiseErrs [String
wrongNoOfArgsErr]
      ([Flag]
_   , [String]
_   , [String]
errs)  -> [String] -> CST s ()
forall s a. [String] -> CST s a
raiseErrs [String]
errs
  where
    properArgs :: [String] -> Bool
properArgs [String
file1, String
file2] = String -> String
suffix String
file1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hsuffix
                                Bool -> Bool -> Bool
&& String -> String
suffix String
file2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
chssuffix
    properArgs [String]
_              = Bool
False
    --
    doExecute :: [Flag] -> [String] -> PreCST SwitchBoard s ()
doExecute [Flag]
opts [String]
args = [Flag] -> [String] -> PreCST SwitchBoard s ()
forall s. [Flag] -> [String] -> PreCST SwitchBoard s ()
execute [Flag]
opts [String]
args
                              PreCST SwitchBoard s ()
-> (IOError -> PreCST SwitchBoard s ()) -> PreCST SwitchBoard s ()
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` IOError -> PreCST SwitchBoard s ()
forall e s b. IOError -> PreCST e s b
failureHandler
    --
    wrongNoOfArgsErr :: String
wrongNoOfArgsErr =
      String
"Supply the header file followed by the binding file.\n\
      \The header file can be omitted if it is supplied in the binding file.\n\
      \The binding file can be omitted if the --precomp flag is given.\n"
    --
    -- exception handler
    --
    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

-- set up base configuration
--
setup :: CST s ()
setup :: CST s ()
setup  = do
           String -> CST s ()
forall s. String -> CST s ()
setCPP     String
cpp
           [String] -> CST s ()
forall s. [String] -> CST s ()
addCPPOpts [String]
cppopts
           [String] -> CST s ()
forall s. [String] -> CST s ()
addHPaths  [String]
hpaths

-- output error message
--
raiseErrs      :: [String] -> CST s a
raiseErrs :: [String] -> CST s a
raiseErrs [String]
errs = do
                   Handle -> String -> PreCST SwitchBoard s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errs)
                   Handle -> String -> PreCST SwitchBoard s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr String
errTrailer
                   ExitCode -> CST s a
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (ExitCode -> CST s a) -> ExitCode -> CST s a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

-- 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 :: [Flag] -> [String] -> CST s ()
execute [Flag]
opts [String]
args | Flag
Help Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
opts = CST s ()
forall s. CST s ()
help
                  | Bool
otherwise        =
  do
    let vs :: [Flag]
vs      = (Flag -> Bool) -> [Flag] -> [Flag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
== Flag
Version) [Flag]
opts
        opts' :: [Flag]
opts'   = (Flag -> Bool) -> [Flag] -> [Flag]
forall a. (a -> Bool) -> [a] -> [a]
filter (Flag -> Flag -> Bool
forall a. Eq a => a -> a -> Bool
/= Flag
Version) [Flag]
opts
    (Flag -> CST s ()) -> [Flag] -> CST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Flag -> CST s ()
forall s. Flag -> CST s ()
processOpt ([Flag] -> [Flag]
forall a. [a] -> [a]
atMostOne [Flag]
vs [Flag] -> [Flag] -> [Flag]
forall a. [a] -> [a] -> [a]
++ [Flag]
opts')

    let (String
headerFile, String
bndFile) = [String] -> (String, String)
determineFileTypes [String]
args

    Maybe String
preCompFile <- (SwitchBoard -> Maybe String) -> CST s (Maybe String)
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Maybe String
preCompSB

    Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe String
preCompFileMaybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe String
forall a. Maybe a
Nothing) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> CST s ()
forall s. String -> String -> CST s ()
preCompileHeader String
headerFile (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
preCompFile)
        CST s () -> (IOError -> CST s ()) -> CST s ()
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` IOError -> CST s ()
forall e s b. IOError -> PreCST e s b
ioErrorHandler

    let bndFileWithoutSuffix :: String
bndFileWithoutSuffix  = String -> String
stripSuffix String
bndFile
    Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
bndFile) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$ do
      String -> CST s ()
forall s. String -> CST s ()
computeOutputName String
bndFileWithoutSuffix
      String -> Maybe String -> String -> CST s ()
forall s. String -> Maybe String -> String -> CST s ()
process String
headerFile Maybe String
preCompFile String
bndFileWithoutSuffix
               CST s () -> (IOError -> CST s ()) -> CST s ()
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` IOError -> CST s ()
forall e s b. IOError -> PreCST e s b
ioErrorHandler
  where
    atMostOne :: [a] -> [a]
atMostOne = (([a] -> a -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[a]
_ a
x -> [a
x]) [])

    determineFileTypes :: [String] -> (String, String)
determineFileTypes [String
hfile, String
bfile]                = (String
hfile, String
bfile)
    determineFileTypes [String
file] | String -> String
suffix String
fileString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
hsuffix = (String
file, String
"")
                              | Bool
otherwise            = (String
"", String
file)
    determineFileTypes []                            = (String
"", String
"")

    ioErrorHandler :: IOError -> PreCST e s b
ioErrorHandler IOError
ioerr = do
                             String
name <- PreCST e s String
forall e s. PreCST e s String
getProgNameCIO
                             String -> PreCST e s ()
forall e s. String -> PreCST e s ()
putStrCIO (String -> PreCST e s ()) -> String -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$
                               String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
ioeGetErrorString IOError
ioerr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
                             ExitCode -> PreCST e s b
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (ExitCode -> PreCST e s b) -> ExitCode -> PreCST e s b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1

-- emit help message
--
help :: CST s ()
help :: CST s ()
help  = do
          (String
version, String
copyright, String
disclaimer) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
          String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO (String -> [OptDescr Flag] -> String
forall a. String -> [OptDescr a] -> String
usageInfo (String -> String -> String -> String
header String
version String
copyright String
disclaimer) [OptDescr Flag]
options)
          String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
trailer

-- process an option
--
--  * `Help' cannot occur
--
processOpt                   :: Flag -> CST s ()
processOpt :: Flag -> CST s ()
processOpt (CPPOpts String
cppopt )  = [String] -> CST s ()
forall s. [String] -> CST s ()
addCPPOpts [String
cppopt]
processOpt (CPP     String
cpp    )  = String -> CST s ()
forall s. String -> CST s ()
setCPP     String
cpp
processOpt (Dump    DumpType
dt     )  = DumpType -> CST s ()
forall s. DumpType -> CST s ()
setDump    DumpType
dt
processOpt (Flag
Keep           )  = CST s ()
forall s. CST s ()
setKeep
processOpt (Include String
dirs   )  = String -> CST s ()
forall s. String -> CST s ()
setInclude String
dirs
processOpt (Output  String
fname  )  = String -> CST s ()
forall s. String -> CST s ()
setOutput  String
fname
processOpt (OutDir  String
fname  )  = String -> CST s ()
forall s. String -> CST s ()
setOutDir  String
fname
processOpt (PreComp String
fname  )  = String -> CST s ()
forall s. String -> CST s ()
setPreComp String
fname
processOpt (LockFun String
name   )  = String -> CST s ()
forall s. String -> CST s ()
setLockFun String
name
processOpt Flag
Version            = do
                                  (String
version, String
_, String
_) <- PreCST SwitchBoard s (String, String, String)
forall e s. PreCST e s (String, String, String)
getId
                                  String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO (String
version String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
processOpt (Error   String
msg    )  = String -> CST s ()
forall s. String -> CST s ()
abort      String
msg

-- emit error message and raise an error
--
abort     :: String -> CST s ()
abort :: String -> CST s ()
abort String
msg  = do
               Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrLnCIO Handle
stderr String
msg
               Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
stderr String
errTrailer
               String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error in command line options"

-- 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 :: String -> CST s ()
computeOutputName String
bndFileNoSuffix =
  do
    String
output <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
    String
outDir <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outDirSB
    let dir :: String
dir  = if      String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outDir Bool -> Bool -> Bool
&& String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output then String -> String
dirname String
bndFileNoSuffix
               else if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outDir                then String -> String
dirname String
output
               else                                    String
outDir
    let base :: String
base = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output then String -> String
basename String
bndFileNoSuffix
               else                String -> String
basename String
output
    (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {
                         outputSB :: String
outputSB = String
dir String -> String -> String
`addPath` String
base,
                         outDirSB :: String
outDirSB = String
dir
                       }


-- 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 :: [String] -> CST s ()
addCPPOpts [String]
opts  =
  do
    let iopts :: [String]
iopts = [String
opt | String
opt <- [String]
opts, String
"-I" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
opt, String
"-I-" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
opt]
    [String] -> CST s ()
forall s. [String] -> CST s ()
addHPaths ([String] -> CST s ())
-> ([String] -> [String]) -> [String] -> CST s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2) ([String] -> CST s ()) -> [String] -> CST s ()
forall a b. (a -> b) -> a -> b
$ [String]
iopts
    [String] -> CST s ()
forall s. [String] -> CST s ()
addOpts [String]
opts
  where
    addOpts :: [String] -> CST s ()
addOpts [String]
opts  = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$
                      \SwitchBoard
sb -> SwitchBoard
sb {cppOptsSB :: [String]
cppOptsSB = SwitchBoard -> [String]
cppOptsSB SwitchBoard
sb [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
opts}

-- set the program name of the C proprocessor
--
setCPP       :: FilePath -> CST s ()
setCPP :: String -> CST s ()
setCPP String
fname  = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {cppSB :: String
cppSB = String
fname}

-- add header file search paths
--
addHPaths       :: [FilePath] -> CST s ()
addHPaths :: [String] -> CST s ()
addHPaths [String]
paths  = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {hpathsSB :: [String]
hpathsSB = [String]
paths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ SwitchBoard -> [String]
hpathsSB SwitchBoard
sb}

-- set the given dump option
--
setDump         :: DumpType -> CST s ()
setDump :: DumpType -> CST s ()
setDump DumpType
Trace    = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {tracePhasesSW :: Bool
tracePhasesSW  = Bool
True}
setDump DumpType
GenBind  = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {traceGenBindSW :: Bool
traceGenBindSW = Bool
True}
setDump DumpType
CTrav    = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {traceCTravSW :: Bool
traceCTravSW   = Bool
True}
setDump DumpType
CHS      = (Traces -> Traces) -> CST s ()
forall s. (Traces -> Traces) -> CST s ()
setTraces ((Traces -> Traces) -> CST s ()) -> (Traces -> Traces) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \Traces
ts -> Traces
ts {dumpCHSSW :: Bool
dumpCHSSW      = Bool
True}

-- set flag to keep the pre-processed header file
--
setKeep :: CST s ()
setKeep :: CST s ()
setKeep  = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {keepSB :: Bool
keepSB = Bool
True}

-- 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 :: String -> CST s ()
setInclude String
str = do
  let fp :: [String]
fp = String -> [String]
splitSearchPath String
str
  (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {chiPathSB :: [String]
chiPathSB = [String]
fp [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (SwitchBoard -> [String]
chiPathSB SwitchBoard
sb)}

-- set the output file name
--
setOutput       :: FilePath -> CST s ()
setOutput :: String -> CST s ()
setOutput String
fname  = do
                     Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> String
suffix String
fname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
hssuffix) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
                       [String] -> CST s ()
forall s a. [String] -> CST s a
raiseErrs [String
"Output file should end in .hs!\n"]
                     (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {outputSB :: String
outputSB = String -> String
stripSuffix String
fname}

-- set the output directory
--
setOutDir       :: FilePath -> CST s ()
setOutDir :: String -> CST s ()
setOutDir String
fname  = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {outDirSB :: String
outDirSB = String
fname}

-- set the name of the generated header file
--
setHeader       :: FilePath -> CST s ()
setHeader :: String -> CST s ()
setHeader String
fname  = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb {headerSB :: String
headerSB = String
fname}

-- set the file name in which the precompiled header ends up
--
setPreComp      :: FilePath -> CST s ()
setPreComp :: String -> CST s ()
setPreComp String
fname = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb { preCompSB :: Maybe String
preCompSB = String -> Maybe String
forall a. a -> Maybe a
Just String
fname }

-- set the name of the wrapper function that acquires a lock
--
setLockFun      :: String -> CST s ()
setLockFun :: String -> CST s ()
setLockFun String
name = (SwitchBoard -> SwitchBoard) -> CST s ()
forall s. (SwitchBoard -> SwitchBoard) -> CST s ()
setSwitch ((SwitchBoard -> SwitchBoard) -> CST s ())
-> (SwitchBoard -> SwitchBoard) -> CST s ()
forall a b. (a -> b) -> a -> b
$ \SwitchBoard
sb -> SwitchBoard
sb { lockFunSB :: Maybe String
lockFunSB = String -> Maybe String
forall a. a -> Maybe a
Just String
name }

-- 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 :: String -> Maybe String -> String -> CST s ()
process String
headerFile Maybe String
preCompFile String
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
    --
    (CHSModule
chsMod , String
warnmsgs) <- String -> CST s (CHSModule, String)
forall s. String -> CST s (CHSModule, String)
loadCHS String
bndFile

    String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs

    -- check if a CPP language pragma is present and, if so, run CPP on the file
    -- and re-read it
    CHSModule
chsMod <- case CHSModule -> Maybe CHSModule
skipToLangPragma CHSModule
chsMod of
      Maybe CHSModule
Nothing -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod
      Just CHSModule
chsMod | Bool -> Bool
not (CHSModule -> Bool
hasCPP CHSModule
chsMod) -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod
                  | Bool
otherwise -> do
        String
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
        let outFileBase :: String
outFileBase  = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outFName then String -> String
basename String
bndFile else String
outFName
        let ppFile :: String
ppFile = String
outFileBase String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chssuffix
        String
cpp     <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
cppSB
        [String]
cppOpts <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
cppOptsSB
        let args :: [String]
args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
cppoptsdef, String
headerFile, String
bndFile]
        String -> CST s ()
forall s. String -> CST s ()
tracePreproc ([String] -> String
unwords (String
cppString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
        ExitCode
exitCode <- IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a e s. IO a -> PreCST e s a
liftIO (IO ExitCode -> PreCST SwitchBoard s ExitCode)
-> IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a b. (a -> b) -> a -> b
$ do
          Handle
ppHnd <- String -> IOMode -> IO Handle
openFile String
ppFile IOMode
WriteMode
          ProcessHandle
process <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cpp [String]
args
            Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
ppHnd) Maybe Handle
forall a. Maybe a
Nothing
          ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
        case ExitCode
exitCode of
          ExitFailure Int
_ -> String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing chs file"
          ExitCode
_             -> CST s ()
forall e s. PreCST e s ()
nop

        (CHSModule
chsMod , String
warnmsgs) <- String -> CST s (CHSModule, String)
forall s. String -> CST s (CHSModule, String)
loadCHS String
ppFile

        Bool
keep <- (SwitchBoard -> Bool) -> CST s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
keepSB
        Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keep (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
          String -> CST s ()
forall e s. String -> PreCST e s ()
removeFileCIO String
ppFile

        case CHSModule -> Maybe CHSModule
skipToLangPragma CHSModule
chsMod of Just CHSModule
chsMod -> CHSModule -> PreCST SwitchBoard s CHSModule
forall s. CHSModule -> CST s CHSModule
loadAllCHI CHSModule
chsMod

    CHSModule -> CST s ()
forall s. CHSModule -> PreCST SwitchBoard s ()
traceCHSDump CHSModule
chsMod
    --
    -- 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)
    --
    ([String]
header, CHSModule
strippedCHSMod, String
warnmsgs) <- CHSModule -> CST s ([String], CHSModule, String)
forall s. CHSModule -> CST s ([String], CHSModule, String)
genHeader CHSModule
chsMod
    String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs

    Bool
pcFileExists <- CST s Bool -> (String -> CST s Bool) -> Maybe String -> CST s Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> CST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) String -> CST s Bool
forall e s. String -> PreCST e s Bool
doesFileExistCIO Maybe String
preCompFile

    AttrC
cheader <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
header Bool -> Bool -> Bool
&& Bool
pcFileExists then do
        -- there are no cpp directives in the .chs file, use the precompiled header
        --
        String -> CST s ()
forall s. String -> CST s ()
traceReadPrecomp (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
preCompFile)
        WithNameSupply AttrC
cheader <- IO (WithNameSupply AttrC)
-> PreCST SwitchBoard s (WithNameSupply AttrC)
forall a e s. IO a -> PreCST e s a
liftIO (IO (WithNameSupply AttrC)
 -> PreCST SwitchBoard s (WithNameSupply AttrC))
-> IO (WithNameSupply AttrC)
-> PreCST SwitchBoard s (WithNameSupply AttrC)
forall a b. (a -> b) -> a -> b
$ String -> IO (WithNameSupply AttrC)
forall a. Binary a => String -> IO a
getBinFileWithDict (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
preCompFile)
        AttrC -> PreCST SwitchBoard s AttrC
forall (m :: * -> *) a. Monad m => a -> m a
return AttrC
cheader

      else do
        --
        -- create new header file, make it #include `headerFile', and emit
        -- CPP and inline-C of .chs file into the new header
        --
        String
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
        let newHeaderFile :: String
newHeaderFile = String
outFName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsuffix
        let preprocFile :: String
preprocFile   = String -> String
basename String
newHeaderFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isuffix
        Handle
newHeader <- String -> IOMode -> PreCST SwitchBoard s Handle
forall e s. String -> IOMode -> PreCST e s Handle
openFileCIO String
newHeaderFile IOMode
WriteMode
        Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
headerFile) (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
          Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrLnCIO Handle
newHeader (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$ String
"#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
headerFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
        (String -> CST s ()) -> [String] -> PreCST SwitchBoard s [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Handle -> String -> CST s ()
forall e s. Handle -> String -> PreCST e s ()
hPutStrCIO Handle
newHeader) [String]
header
        Handle -> CST s ()
forall e s. Handle -> PreCST e s ()
hCloseCIO Handle
newHeader
        String -> CST s ()
forall s. String -> CST s ()
setHeader String
newHeaderFile
        --
        -- run C preprocessor over the header
        --
        String
cpp     <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
cppSB
        [String]
cppOpts <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
cppOptsSB
        let args :: [String]
args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
newHeaderFile]
        String -> CST s ()
forall s. String -> CST s ()
tracePreproc ([String] -> String
unwords (String
cppString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
        ExitCode
exitCode <- IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a e s. IO a -> PreCST e s a
liftIO (IO ExitCode -> PreCST SwitchBoard s ExitCode)
-> IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a b. (a -> b) -> a -> b
$ do
          Handle
preprocHnd <- String -> IOMode -> IO Handle
openFile String
preprocFile IOMode
WriteMode
          ProcessHandle
process <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cpp [String]
args
            Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
preprocHnd) Maybe Handle
forall a. Maybe a
Nothing
          ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
        case ExitCode
exitCode of
          ExitFailure Int
_ -> String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing custom header file"
          ExitCode
_             -> CST s ()
forall e s. PreCST e s ()
nop
        --
        -- load and analyse the C header file
        --
        (AttrC
cheader, String
warnmsgs) <- String -> CST s (AttrC, String)
forall s. String -> CST s (AttrC, String)
loadAttrC String
preprocFile
        String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
        --
        -- remove the custom header and the pre-processed header
        --
        Bool
keep <- (SwitchBoard -> Bool) -> CST s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
keepSB
        Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keep (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
          String -> CST s ()
forall e s. String -> PreCST e s ()
removeFileCIO String
preprocFile

        AttrC -> PreCST SwitchBoard s AttrC
forall (m :: * -> *) a. Monad m => a -> m a
return AttrC
cheader

    --
    -- expand binding hooks into plain Haskell
    --
    (CHSModule
hsMod, String
chi, String
warnmsgs) <- AttrC -> CHSModule -> CST s (CHSModule, String, String)
forall s. AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks AttrC
cheader CHSModule
strippedCHSMod
    String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs
    --
    -- output the result
    --
    String
outFName <- (SwitchBoard -> String) -> CST s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
outputSB
    let hsFile :: String
hsFile  = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
outFName then String -> String
basename String
bndFile else String
outFName
    String -> CHSModule -> Bool -> CST s ()
forall s. String -> CHSModule -> Bool -> CST s ()
dumpCHS String
hsFile CHSModule
hsMod Bool
True
    String -> String -> CST s ()
forall s. String -> String -> CST s ()
dumpCHI String
hsFile String
chi          -- different suffix will be appended

  where
    bndFile :: String
bndFile = String
bndFileStripped String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chssuffix
    traceReadPrecomp :: String -> CST s ()
traceReadPrecomp String
fName = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
      String
"Reading precompiled header file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"...\n"
    tracePreproc :: String -> CST s ()
tracePreproc String
cmd = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
                         String
"Invoking cpp as `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n"
    traceCHSDump :: CHSModule -> PreCST SwitchBoard s ()
traceCHSDump CHSModule
mod = do
                         Bool
flag <- (Traces -> Bool) -> CST s Bool
forall s. (Traces -> Bool) -> CST s Bool
traceSet Traces -> Bool
dumpCHSSW
                         Bool -> PreCST SwitchBoard s () -> PreCST SwitchBoard s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
flag (PreCST SwitchBoard s () -> PreCST SwitchBoard s ())
-> PreCST SwitchBoard s () -> PreCST SwitchBoard s ()
forall a b. (a -> b) -> a -> b
$
                           (do
                              String -> PreCST SwitchBoard s ()
forall e s. String -> PreCST e s ()
putStrCIO (String
"...dumping CHS to `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chsName
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n")
                              String -> CHSModule -> Bool -> PreCST SwitchBoard s ()
forall s. String -> CHSModule -> Bool -> CST s ()
dumpCHS String
chsName CHSModule
mod Bool
False)

    chsName :: String
chsName = String -> String
basename String
bndFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".dump"

preCompileHeader :: FilePath -> FilePath -> CST s ()
preCompileHeader :: String -> String -> CST s ()
preCompileHeader String
headerFile String
preCompFile =
  do
    let preprocFile :: String
preprocFile  = String -> String
basename String
headerFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isuffix

    Bool
pcFileExists <- String -> PreCST SwitchBoard s Bool
forall e s. String -> PreCST e s Bool
doesFileExistCIO String
preCompFile
    Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
pcFileExists (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$ do

    [String]
hpaths          <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
hpathsSB
    String
realHeaderFile  <- String
headerFile String -> [String] -> PreCST SwitchBoard s String
forall e s. String -> [String] -> PreCST e s String
`fileFindInCIO` [String]
hpaths

    --
    -- run C preprocessor over the header
    --
    String
cpp     <- (SwitchBoard -> String) -> PreCST SwitchBoard s String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
cppSB
    [String]
cppOpts <- (SwitchBoard -> [String]) -> CST s [String]
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
cppOptsSB
    let args :: [String]
args = [String]
cppOpts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
realHeaderFile]
    String -> CST s ()
forall s. String -> CST s ()
tracePreproc ([String] -> String
unwords (String
cppString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args))
    ExitCode
exitCode <- IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a e s. IO a -> PreCST e s a
liftIO (IO ExitCode -> PreCST SwitchBoard s ExitCode)
-> IO ExitCode -> PreCST SwitchBoard s ExitCode
forall a b. (a -> b) -> a -> b
$ do
      Handle
preprocHnd <- String -> IOMode -> IO Handle
openFile String
preprocFile IOMode
WriteMode
      ProcessHandle
process <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ProcessHandle
runProcess String
cpp [String]
args
        Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
preprocHnd) Maybe Handle
forall a. Maybe a
Nothing
      ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process
    case ExitCode
exitCode of
      ExitFailure Int
_ -> String -> CST s ()
forall e s a. String -> PreCST e s a
fatal String
"Error during preprocessing"
      ExitCode
_             -> CST s ()
forall e s. PreCST e s ()
nop

    --
    -- load and analyse the C header file
    --
    (AttrC
cheader, String
warnmsgs) <- String -> CST s (AttrC, String)
forall s. String -> CST s (AttrC, String)
loadAttrC String
preprocFile
    String -> CST s ()
forall e s. String -> PreCST e s ()
putStrCIO String
warnmsgs

    --
    -- save the attributed C to disk
    --
    IO () -> CST s ()
forall a e s. IO a -> PreCST e s a
liftIO (IO () -> CST s ()) -> IO () -> CST s ()
forall a b. (a -> b) -> a -> b
$ String -> WithNameSupply AttrC -> IO ()
forall a. Binary a => String -> a -> IO ()
putBinFileWithDict String
preCompFile (AttrC -> WithNameSupply AttrC
forall a. a -> WithNameSupply a
WithNameSupply AttrC
cheader)

    --
    -- remove the pre-processed header
    --
    Bool
keep <- (SwitchBoard -> Bool) -> PreCST SwitchBoard s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
keepSB
    Bool -> CST s () -> CST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
keep (CST s () -> CST s ()) -> CST s () -> CST s ()
forall a b. (a -> b) -> a -> b
$
      String -> CST s ()
forall e s. String -> PreCST e s ()
removeFileCIO String
preprocFile

    () -> CST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    tracePreproc :: String -> CST s ()
tracePreproc String
cmd = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW (String -> CST s ()) -> String -> CST s ()
forall a b. (a -> b) -> a -> b
$
                         String
"Invoking cpp as `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'...\n"


-- dummy type so we can save and restore the name supply
data WithNameSupply a = WithNameSupply a

instance Binary a => Binary (WithNameSupply a) where
  put_ :: BinHandle -> WithNameSupply a -> IO ()
put_ BinHandle
bh (WithNameSupply a
x) = do
    BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
x
    Name
nameSupply <- IO Name
saveRootNameSupply
    BinHandle -> Name -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Name
nameSupply
  get :: BinHandle -> IO (WithNameSupply a)
get BinHandle
bh = do
    a
x <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    Name
nameSupply <- BinHandle -> IO Name
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    Name -> IO ()
restoreRootNameSupply Name
nameSupply
    WithNameSupply a -> IO (WithNameSupply a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> WithNameSupply a
forall a. a -> WithNameSupply a
WithNameSupply a
x)