%
% (c) The Foo Project, Universities of Glasgow & Utrecht, 1997-8
%
% @(#) $Docid: Jun. 9th 2003 12:58 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
The toplevel driver for the IDL compiler
\begin{code}
module Main
( main
, hdirectHelp
) where
import LexM
import qualified Parser (parseIDL)
import qualified OmgParser (parseIDL)
import Opts
import PpCore ( ppCore, showCore, showHeader, ppHeaderDecl )
import CoreUtils ( getInterfaceIds )
import PpIDLSyn ( ppIDL, showIDL )
import IDLSyn ( Attribute, Defn )
import IDLUtils ( sortDefns, winnowDefns )
import CoreIDL ( Decl )
import AbstractH ( HTopDecl(..) )
import PpAbstractH ( ppHTopDecls, showAbstractH )
import PreProc
import Desugar
import Rename
import IO ( hPutStr, hPutStrLn, stderr, stdout, hPutChar,
openFile, IOMode(..), hClose, Handle, hFlush
)
import Monad ( when )
import System (getProgName, exitWith, ExitCode(..) )
import CodeGen
import Utils ( dropSuffix, basename, notNull )
import Time
import List ( partition )
import Version
import Locale
import HugsCodeGen
import DefGen
import CStubGen
import JavaProxy
import Env ( newEnv, addListToEnv_C )
\end{code}
\begin{code}
main :: IO ()
main
| optVersion = putStrLn version_msg
| optHelp = do { pgm <- getProgName ; putStrLn (usage_msg pgm) }
| otherwise = do
file <- getInpFile
case file of
Nothing -> do { pgm <- getProgName ; putStrLn (usage_msg pgm) }
Just fnames -> do
case optOFiles of
(_:_) | length fnames > 1 -> do
pgm <- getProgName
hFlush stdout
hPutStr stderr pgm
hPutStrLn stderr (": you cannot use -o if you have multiple input files")
hPutStrLn stderr (usage_msg pgm)
exitWith (ExitFailure 1)
_ -> do
let
oFileFun | length fnames == 1 = \ n -> (oFile n, oModNm n)
| otherwise = \ n -> (Right (oFileFromInput n), oModNm n)
incls = optincludedirs ++ ["."]
if not optTlb
then do
sequence (map (\ f -> processFile incls f (oFileFun f)) fnames)
return ()
else do
let src = unlines $ map (\ x -> "importlib(" ++ show x ++ ");") fnames
inp = Left src
hPutStrLn stderr "WARNING: Type library reading code not compiled in; Ignoring --tlb option"
let o_fnm = oFile (head fnames)
o_modnm = oModNm (head fnames)
processSource incls "<typelib>" inp (o_fnm, o_modnm)
where
oModNm _ = case optOutputModules of { (x:_) -> Just x ; _ -> Nothing }
oFile nm = case optOFiles of { (x:_) -> Left x ; _ -> Right (oFileFromInput nm) }
oFileFromInput nm =
case nm of
"-" -> nm
_
| optServer -> (dropSuffix nm) ++ "Proxy.hs"
| otherwise -> (dropSuffix nm) ++ ".hs"
getInpFile =
case optFiles of
[] -> return Nothing
_ -> return (Just (reverse optFiles))
hdirectHelp :: IO ()
hdirectHelp = do
pgm <- getProgName
putStrLn (usage_msg pgm)
\end{code}
\begin{code}
processFile :: [String]
-> String
-> (Either String String, Maybe String)
-> IO ()
processFile path fname ofname = do
fname' <- preProcessFile fname
ls <-
case fname' of
"-" -> getContents
_ -> readFile fname'
processSource path fname (Left ls) ofname
processAsf :: [String]
-> String
-> IO [(String,Bool,[Attribute])]
processAsf path fname = do
when optVerbose (hFlush stdout >> hPutStrLn stderr ("Processing ASF: " ++ fname))
ls <-
case fname of
"-" -> getContents
_ -> readFile fname
Right x <- runLexM path fname ('=':ls) Parser.parseIDL
return x
showPassMsg :: String -> IO ()
showPassMsg msg = do
hFlush stdout
hPutStrLn stderr ("***" ++ msg)
hFlush stderr
processSource :: [String]
-> String
-> Either String [Defn]
-> (Either String String, Maybe String)
-> IO ()
processSource path fname ls ofname = do
when optShowPasses (showPassMsg "Reader")
defs <-
case ls of
Left str ->
catch
(runLexM path fname str parseIDL)
(\ err -> removeTmp >> ioError err)
Right ds -> return ds
when (optShowPasses && notNull optAsfs)
(showPassMsg "Asf reader")
asfs <- mapM (processAsf path) optAsfs
let
s_defs
| optWinnowDefns || optSortDefns || optJNI = sortDefns defs
| otherwise = defs
w_defs
| optWinnowDefns = winnowDefns asf_env s_defs
| otherwise = s_defs
combineAsf (f1, old) (f2, new) = (f1 && f2, old ++ new)
asf_env = addListToEnv_C combineAsf newEnv
(map (\ (x,y,z) -> (x, (y,z))) (concat asfs))
os = showIDL (ppIDL fname w_defs)
dumpPass dumpIDL "Parsed IDL" os
when optShowPasses (showPassMsg "Desugarer")
(core_decls, tenv, tg_env, senv, ifenv) <- desugar fname asf_env w_defs
let cs = showCore (ppCore core_decls)
dumpPass dumpDesugar "Desugared IDL" cs
let (renamed_decls, iso_env, iface_env)
= renameDecls tenv tg_env senv ifenv core_decls
rs = showCore (ppCore renamed_decls)
dumpPass dumpRenamer "Renamed Core IDL" rs
when (optOutputTlb || notNull optOutputTlbTo)
(hPutStrLn stderr "WARNING: type library handling code not compiled in; ignoring --output-tlb= option")
when optShowPasses (showPassMsg "CodeGen")
let (header, code) = codeGen ofname iso_env iface_env renamed_decls
code_str = unlines (map showCode code)
dumpPass dumpAbstractH "Abstract Haskell" code_str
when optShowPasses (showPassMsg "CodeOutput")
when (optJNI && optServer) (writeJava renamed_decls)
writeHeader header
let def_files = defGen code
when (not optNoOutput && optGenDefs)
(sequence_ (map (uncurry writeOutStuff) def_files))
when (not optNoOutput)
(writeCode True code)
removeTmp
parseIDL :: LexM [Defn]
parseIDL
| optCompilingOmgIDL = OmgParser.parseIDL
| otherwise = Parser.parseIDL >>= \ (Left x) -> return x
\end{code}
Bunch of small helper functions to write out and show code.
\begin{code}
showCode :: (String, Bool, [HTopDecl]) -> String
showCode (nm, _, ds) = file_msg (showAbstractH (ppHTopDecls ds))
where
file_msg cont
| generateGreenCard = "File: "++ show (dropSuffix nm ++ ".gc") ++ '\n':cont
| otherwise = "File: "++ show nm ++ '\n':cont
generateGreenCard :: Bool
generateGreenCard = not optNoOutput && optGreenCard
writeCode :: Bool -> [(String, Bool, [HTopDecl])] -> IO ()
writeCode _ [] = return ()
writeCode is_haskell ((nm, flg, md):rs) = do
writeOutCode
when (is_haskell && flg) $ do
hFlush stdout
hPutStrLn stderr
("Notice: Need to generate C stubs as well for module " ++ show (dropSuffix nm) ++ ",")
hPutStrLn stderr
(" since it contains methods that passes structs/unions")
hPutStrLn stderr
(" by value.")
when (not optNoOutput && is_haskell && (optHugs || optGenCStubs || flg))
(writeCode False [(nm,flg,md)])
writeCode is_haskell rs
where
writeOutCode = writeOut incs is_haskell False out_nm (showDecls non_incs)
showDecls
| is_haskell = showAbstractH.ppHTopDecls
| not optHugs = cStubGen out_nm
| otherwise = hugsCodeGen out_nm
incs = map (\ (HInclude s) -> s) incs'
(incs',non_incs) = partition filterIncludes md
filterIncludes HInclude{} = is_haskell
filterIncludes _ = False
out_nm =
case nm of
"-" -> nm
_
| generateGreenCard -> dropSuffix nm ++ ".gc"
| not is_haskell -> dropSuffix nm ++ ".c"
| otherwise -> nm
writeOut :: [String] -> Bool -> Bool -> String -> String -> IO ()
writeOut _ _ _ _ "" = return ()
writeOut incs is_haskell no_hdrs fname_prim stuff = do
when (optVerbose && fname /= "-") (hFlush stdout >> hPutStr stderr ("Writing " ++ fname))
case fname of
"-" -> do
hPutBanner embed_comment stdout
includes_at_top stdout
putStrLn stuff
_ -> do
hp <- openFile fname WriteMode
when is_haskell (includes_at_top hp)
hPutBanner embed_comment hp
when (not is_haskell) (includes_at_top hp)
hPutStrLn hp stuff
hClose hp
when optVerbose (hFlush stdout >> hPutChar stderr '\n')
where
fname =
case fname_prim of
"-" -> fname_prim
_ ->
case optODirs of
(x:_) -> x ++ '/':basename fname_prim
_ -> fname_prim
dirs
| no_hdrs = incs
| is_haskell = optIncludeHeaders ++ incs
| otherwise = optIncludeCHeaders ++ optIncludeHeaders ++ incs
embed_comment ls
| is_haskell = unlines (map (\ x -> '-':'-':' ':x) ls)
| otherwise = block_comment ls ++
unlines
[ ""
, if optHugs then "#include \"HDirect.h\"" else ""
, "#ifndef __INT64_DEFINED__"
, "#ifdef __GNUC__"
, "typedef long long int64;"
, "typedef unsigned long long uint64;"
, "#else"
, "#ifdef _MSC_VER"
, "typedef __int64 int64;"
, "typedef unsigned __int64 uint64;"
, "#else"
, "/* Need some help here, please. */"
, "#endif"
, "#endif"
, "#define __INT64_DEFINED__"
, "#endif"
, ""
]
includes_at_top hp
| null dirs || optGreenCard = return ()
| otherwise = do
sequence (map (gen_options hp) dirs)
return ()
gen_options hp hfile =
case hfile of
[] -> return ()
_ -> hPutStrLn hp (gen_include (showFn hfile))
where
gen_include fn
| is_haskell = "{-# OPTIONS -#include " ++ fn ++ " #-}"
| otherwise = "#include " ++ fn
showFn ls@('"':_) = ls
showFn ls@('<':_) = ls
showFn ls = show ls
hPutBanner :: ([String] -> String) -> Handle -> IO ()
hPutBanner comment hp = do
ls <- mkBanner comment
hPutStrLn hp ls
mkBanner :: ([String] -> String) -> IO String
mkBanner comment = do
cal <- getClockTime >>= toCalendarTime
let date = formatCalendarTime defaultTimeLocale "%H:%M %Z, %A %d %B, %Y" cal
return (comment
[ "Automatically generated by " ++ pkg_name ++ ", " ++ pkg_version
, "Created: " ++ date
, "Command line: " ++ unwords theOpts
])
block_comment :: [String] -> String
block_comment ls = unlines ("/*":ls ++ ["*/"])
writeOutStuff :: String -> String -> IO ()
writeOutStuff fname stuff = do
when optVerbose (hFlush stdout >> hPutStr stderr ("Writing " ++ fname))
hp <- openFile fname WriteMode
hPutStrLn hp stuff
hClose hp
when optVerbose (hPutChar stderr '\n')
writeHeader :: [(String, Decl)] -> IO ()
writeHeader ls = do
sequence (map (\ (fname, d) ->
writeOut [] False True
fname
(showHeader fname (ppHeaderDecl (getInterfaceIds d) d)))
ls)
return ()
writeJava :: [Decl] -> IO ()
writeJava ds = do
sequence (map (\ (fname, d) -> do
b <- mkBanner block_comment
writeOutStuff (dropSuffix fname ++ ".java")
(b ++ javaProxyGen d))
ls)
return ()
where
ls = prepareDecls ds
dumpPass :: Bool -> String -> String -> IO ()
dumpPass True hdr stuff =
case optOutputDumpTo of
Nothing -> do
putStrLn ("**** " ++ hdr ++ " ****")
hPutStrLn stdout stuff
Just x -> writeFile x stuff
dumpPass False _ _ = return ()
\end{code}