X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=4afabd2b6898f929f9737f94b680c87f3f9009c3;hb=ce25c4afa4c9ddd5b71b67795cc1ffaf3ac1578f;hp=ee30d09ad455df6865790eb5dbc295662bd238fd;hpb=c63aaee42e3e95276861121286eefce511cd1343;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index ee30d09..4afabd2 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,7 @@ +{-# OPTIONS -fglasgow-exts #-} + ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.41 2002/10/27 10:38:33 mthomas Exp $ +-- $Id: Main.hs,v 1.45 2003/02/11 04:32:06 sof 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. @@ -17,33 +19,26 @@ import GetOpt import Config import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure, system) -import Directory (removeFile) +import Directory (removeFile,doesFileExist) import Monad (MonadPlus(..), liftM, liftM2, when, unless) import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord) import List (intersperse) +import IO (hPutStrLn,stderr) #include "../../includes/config.h" #ifdef mingw32_HOST_OS --- import Win32DLL -import Foreign.C.String (CString, peekCString) -import Foreign.C.Types -import Foreign.Ptr (nullPtr) -import Foreign.Marshal.Alloc (mallocBytes, free) - -foreign import stdcall "GetModuleHandle" c_GetModuleHandle :: CString -> IO CUInt -foreign import stdcall "GetModuleFileName" c_GetModuleFilename :: CUInt -> CString -> CUInt -> IO CUInt - -ourName :: IO String -ourName = do h <- c_GetModuleHandle nullPtr - cstr <- mallocBytes cstr_len - rv <- c_GetModuleFilename h cstr (CUInt (fromIntegral cstr_len)) - str <- peekCString cstr - free cstr - return str - where cstr_len = 512 +import Foreign + +#if __GLASGOW_HASKELL__ >= 504 +import Foreign.C.String +#else +import CString +#endif #endif + + version :: String version = "hsc2hs-0.65" @@ -59,6 +54,10 @@ data Flag | Include String | Define String (Maybe String) | Output String + | Verbose + +template_flag (Template _) = True +template_flag _ = False include :: String -> Flag include s@('\"':_) = Include s @@ -83,34 +82,48 @@ options = [ 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 "v" ["verbose"] (NoArg Verbose) "dump commands to stderr", Option "" ["version"] (NoArg Version) "output version information and exit", Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"] + main :: IO () main = do prog <- getProgName let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]" args <- getArgs - let opts@(flags, files, errs) = getOpt Permute options args -#ifdef mingw32_HOST_OS - n <- ourName - let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h" - let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags - let opts = (fflags, files, errs) -#endif - case opts of - (flags, _, _) - | any isHelp flags -> putStrLn (usageInfo header options) - | any isVersion flags -> putStrLn version + let (flags, files, errs) = getOpt Permute options args + + -- 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 -> putStrLn (usageInfo header options) + | any isVersion flags_w_tpl -> putStrLn 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 + ([], []) -> putStrLn (prog++": No input files") + (files, []) -> mapM_ (processFile flags_w_tpl) files + (_, errs) -> do { mapM_ putStrLn errs ; + putStrLn (usageInfo header options) ; + exitFailure } processFile :: [Flag] -> String -> IO () processFile flags name @@ -124,16 +137,6 @@ processFile flags name exitFailure ------------------------------------------------------------------------ --- Convert paths foo/baz to foo\baz on Windows - -#if defined(mingw32_HOST_OS) -subst a b ls = map (\ x -> if x == a then b else x) ls -dosifyPath xs = subst '/' '\\' xs -#else -dosifyPath xs = xs -#endif - ------------------------------------------------------------------------- -- A deterministic parser which remembers the text which has been parsed. newtype Parser a = Parser (SourcePos -> String -> ParseResult a) @@ -479,6 +482,8 @@ output flags name toks = do 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 = '.':pathSep:progName @@ -493,17 +498,29 @@ 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 cGCC + [] -> locateGhc compiler [l] -> return l _ -> onlyOne "linker" - + writeFile cProgName $ concatMap outFlagHeaderCProg flags++ concatMap outHeaderCProg specials++ @@ -514,8 +531,10 @@ output flags name toks = do " return 0;\n}\n" unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess + + - compilerStatus <- system $ + compilerStatus <- systemL beVerbose $ compiler++ " -c"++ concat [" "++f | CompFlag f <- flags]++ @@ -526,7 +545,7 @@ output flags name toks = do _ -> return () removeFile cProgName - linkerStatus <- system $ + linkerStatus <- systemL beVerbose $ linker++ concat [" "++f | LinkFlag f <- flags]++ " "++oProgName++ @@ -536,7 +555,7 @@ output flags name toks = do _ -> return () removeFile oProgName - progStatus <- system (execProgName++" >"++outName) + progStatus <- systemL beVerbose (execProgName++" >"++outName) removeFile progName case progStatus of e@(ExitFailure _) -> exitWith e @@ -564,6 +583,11 @@ output flags name toks = do -- 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") @@ -760,3 +784,39 @@ showCString = concatMap showCChar 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 + + +#if defined(mingw32_HOST_OS) +subst a b ls = map (\ x -> if x == a then b else x) ls +unDosifyPath xs = subst '\\' '/' xs +dosifyPath xs = subst '/' '\\' xs + +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 s = do return Nothing +#endif