X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=bf77f9da9c559af1f33e37ebfd8f8e4eb8a828ab;hb=363a16df15206022a4cbc9e679bee665047a805c;hp=a2ba3f63e6cc007257e1d07379e488a37d4da315;hpb=7748154b4fcc14bf7281b969605114412dfda696;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index a2ba3f6..bf77f9d 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,7 @@ +{-# OPTIONS -fffi #-} + ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.33 2001/09/12 11:16:05 rrt Exp $ +-- $Id: Main.hs,v 1.52 2004/02/09 17:23:20 ross Exp $ -- -- Program for converting .hsc files to .hs files, by converting the -- file into a C program which is run to generate the Haskell source. @@ -9,22 +11,31 @@ -- -- See the documentation in the Users' Guide for more details. +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 +import System.Console.GetOpt +#else import GetOpt -import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure) -import KludgedSystem -import Directory (removeFile) +#endif + +import System (getProgName, getArgs, ExitCode(..), exitWith, system) +import Directory (removeFile,doesFileExist) import Monad (MonadPlus(..), liftM, liftM2, when, unless) import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord) -import List (intersperse) - -#include "../../includes/config.h" - -#ifdef mingw32_TARGET_OS -import Win32DLL +import List (intersperse, isSuffixOf) +import IO (hPutStr, hPutStrLn, stderr) + +#if defined(mingw32_HOST_OS) +import Foreign +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 +import Foreign.C.String +#else +import CString #endif +#endif + version :: String -version = "hsc2hs-0.65" +version = "hsc2hs version 0.66\n" data Flag = Help @@ -38,6 +49,11 @@ data Flag | Include String | Define String (Maybe String) | Output String + | Verbose + +template_flag :: Flag -> Bool +template_flag (Template _) = True +template_flag _ = False include :: String -> Flag include s@('\"':_) = Include s @@ -51,56 +67,90 @@ define s = case break (== '=') s of options :: [OptDescr Flag] options = [ - Option "t" ["template"] (ReqArg Template "FILE") "template file", - Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use", - Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use", - Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler", - Option "I" [] (ReqArg (CompFlag . ("-I"++)) - "DIR") "passed to the C compiler", - Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker", - Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source", - Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source", - Option "o" ["output"] (ReqArg Output "FILE") "name of main output file", - Option "" ["help"] (NoArg Help) "display this help and exit", - Option "" ["version"] (NoArg Version) "output version information and exit", - Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"] + Option ['o'] ["output"] (ReqArg Output "FILE") + "name of main output file", + Option ['t'] ["template"] (ReqArg Template "FILE") + "template file", + Option ['c'] ["cc"] (ReqArg Compiler "PROG") + "C compiler to use", + Option ['l'] ["ld"] (ReqArg Linker "PROG") + "linker to use", + Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG") + "flag to pass to the C compiler", + Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR") + "passed to the C compiler", + Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG") + "flag to pass to the linker", + Option ['i'] ["include"] (ReqArg include "FILE") + "as if placed in the source", + Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]") + "as if placed in the source", + Option [] ["no-compile"] (NoArg NoCompile) + "stop after writing *_hsc_make.c", + Option ['v'] ["verbose"] (NoArg Verbose) + "dump commands to stderr", + Option ['?'] ["help"] (NoArg Help) + "display this help and exit", + Option ['V'] ["version"] (NoArg Version) + "output version information and exit" ] + main :: IO () main = do - prog <- getProgName - let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]" + prog <- getProgramName + let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n" args <- getArgs -#ifdef mingw32_TARGET_OS - h <- getModuleHandle Nothing - n <- getModuleFileName h - let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h" -#endif let (flags, files, errs) = getOpt Permute options args - let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags - let opts = (fflags, files, errs) - case opts of - (flags, _, _) - | any isHelp flags -> putStrLn (usageInfo header options) - | any isVersion flags -> putStrLn version + + -- If there is no Template flag explicitly specified, try + -- to find one by looking near the executable. This only + -- works on Win32 (getExecDir). On Unix, there's a wrapper + -- script which specifies an explicit template flag. + flags_w_tpl <- if any template_flag flags then + return flags + else + do mb_path <- getExecDir "/bin/hsc2hs.exe" + add_opt <- + case mb_path of + Nothing -> return id + Just path -> do + let templ = path ++ "/template-hsc.h" + flg <- doesFileExist templ + if flg + then return ((Template templ):) + else return id + return (add_opt flags) + case (files, errs) of + (_, _) + | any isHelp flags_w_tpl -> bye (usageInfo header options) + | any isVersion flags_w_tpl -> bye version where isHelp Help = True; isHelp _ = False isVersion Version = True; isVersion _ = False - (_, [], []) -> putStrLn (prog++": No input files") - (flags, files, []) -> mapM_ (processFile flags) files - (_, _, errs) -> do - mapM_ putStrLn errs - putStrLn (usageInfo header options) - exitFailure + ((_:_), []) -> mapM_ (processFile flags_w_tpl) files + (_, _ ) -> die (concat errs ++ usageInfo header options) + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` "-bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) processFile :: [Flag] -> String -> IO () -processFile flags name = do - s <- readFile name - case parser of - Parser p -> case p (SourcePos name 1) s of - Success _ _ _ toks -> output flags name toks - Failure (SourcePos name' line) msg -> do - putStrLn (name'++":"++show line++": "++msg) - exitFailure +processFile flags name + = do let file_name = dosifyPath name + s <- readFile file_name + case parser of + Parser p -> case p (SourcePos file_name 1) s of + Success _ _ _ toks -> output flags file_name toks + Failure (SourcePos name' line) msg -> + die (name'++":"++show line++": "++msg++"\n") ------------------------------------------------------------------------ -- A deterministic parser which remembers the text which has been parsed. @@ -444,12 +494,15 @@ output flags name toks = do let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" - progName = outDir++outBase++"_hsc_make" ++ progNameSuffix - outHName = outDir++outBase++"_hsc.h" + progName = outDir++outBase++"_hsc_make" ++ EXEEXT + outHFile = outBase++"_hsc.h" + outHName = outDir++outHFile outCName = outDir++outBase++"_hsc.c" + + beVerbose = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags let execProgName - | null outDir = "./"++progName + | null outDir = dosifyPath ("./" ++ progName) | otherwise = progName let specials = [(pos, key, arg) | Special pos key arg <- toks] @@ -461,29 +514,43 @@ output flags name toks = do where fixChar c | isAlphaNum c = toUpper c | otherwise = '_' + + -- try locating GHC..on Win32, look in the vicinity of hsc2hs. + locateGhc def = do + mb <- getExecDir "bin/hsc2hs.exe" + case mb of + Nothing -> return def + Just x -> do + let ghc_path = dosifyPath (x ++ "bin/ghc.exe") + flg <- doesFileExist ghc_path + if flg + then return ghc_path + else return def compiler <- case [c | Compiler c <- flags] of - [] -> return "ghc" + [] -> locateGhc "ghc" [c] -> return c _ -> onlyOne "compiler" linker <- case [l | Linker l <- flags] of - [] -> return defaultCompiler + [] -> locateGhc compiler [l] -> return l _ -> onlyOne "linker" - + writeFile cProgName $ concatMap outFlagHeaderCProg flags++ concatMap outHeaderCProg specials++ - "\nint main (void)\n{\n"++ + "\nint main (int argc, char *argv [])\n{\n"++ outHeaderHs flags (if needsH then Just outHName else Nothing) specials++ outHsLine (SourcePos name 0)++ concatMap outTokenHs toks++ " return 0;\n}\n" unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess + + - compilerStatus <- system $ + compilerStatus <- systemL beVerbose $ compiler++ " -c"++ concat [" "++f | CompFlag f <- flags]++ @@ -494,7 +561,7 @@ output flags name toks = do _ -> return () removeFile cProgName - linkerStatus <- system $ + linkerStatus <- systemL beVerbose $ linker++ concat [" "++f | LinkFlag f <- flags]++ " "++oProgName++ @@ -504,8 +571,11 @@ output flags name toks = do _ -> return () removeFile oProgName - system (execProgName++" >"++outName) + progStatus <- systemL beVerbose (execProgName++" >"++outName) removeFile progName + case progStatus of + e@(ExitFailure _) -> exitWith e + _ -> return () when needsH $ writeFile outHName $ "#ifndef "++includeGuard++"\n\ @@ -524,13 +594,18 @@ output flags name toks = do "#endif\n" when needsC $ writeFile outCName $ - "#include \""++outHName++"\"\n"++ + "#include \""++outHFile++"\"\n"++ concatMap outTokenC specials + -- NB. outHFile not outHName; works better when processed + -- by gcc or mkdependC. + +systemL :: Bool -> String -> IO ExitCode +systemL flg s = do + when flg (hPutStrLn stderr ("Executing: " ++ s)) + system s onlyOne :: String -> IO a -onlyOne what = do - putStrLn ("Only one "++what++" may be specified") - exitFailure +onlyOne what = die ("Only one "++what++" may be specified\n") outFlagHeaderCProg :: Flag -> String outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n" @@ -594,9 +669,9 @@ outHeaderHs flags inH toks = showCString s++"\");\n" outTokenHs :: Token -> String -outTokenHs (Text pos text) = - case break (== '\n') text of - (all, []) -> outText all +outTokenHs (Text pos txt) = + case break (== '\n') txt of + (allTxt, []) -> outText allTxt (first, _:rest) -> outText (first++"\n")++ outHsLine pos++ @@ -696,7 +771,7 @@ conditional _ = False outCLine :: SourcePos -> String outCLine (SourcePos name line) = - "# "++show line++" \""++showCString (snd (splitName name))++"\"\n" + "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n" outHsLine :: SourcePos -> String outHsLine (SourcePos name line) = @@ -722,3 +797,44 @@ showCString = concatMap showCChar intToDigit (ord c `quot` 64), intToDigit (ord c `quot` 8 `mod` 8), intToDigit (ord c `mod` 8)] + + + +----------------------------------------- +-- Cut and pasted from ghc/compiler/SysTools +-- Convert paths foo/baz to foo\baz on Windows + +dosifyPath :: String -> String +#if defined(mingw32_HOST_OS) +dosifyPath xs = subst '/' '\\' xs + +unDosifyPath :: String -> String +unDosifyPath xs = subst '\\' '/' xs + +subst :: Eq a => a -> a -> [a] -> [a] +subst a b ls = map (\ x -> if x == a then b else x) ls + +getExecDir :: String -> IO (Maybe String) +-- (getExecDir cmd) returns the directory in which the current +-- executable, which should be called 'cmd', is running +-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, +-- you'll get "/a/b/c" back as the result +getExecDir cmd + = allocaArray len $ \buf -> do + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else do s <- peekCString buf + return (Just (reverse (drop (length cmd) + (reverse (unDosifyPath s))))) + where + len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. + +foreign import stdcall unsafe "GetModuleFileNameA" + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 + +#else +dosifyPath xs = xs + +getExecDir :: String -> IO (Maybe String) +getExecDir _ = return Nothing +#endif