{-# OPTIONS -fffi -cpp #-}
------------------------------------------------------------------------
--- $Id: Main.hs,v 1.65 2005/01/06 14:54:15 malcolm 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.
-- Certain items known only to the C compiler can then be used in
--
-- See the documentation in the Users' Guide for more details.
-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
+#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
+#include "../../includes/ghcconfig.h"
+#endif
+
+#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
import System.Console.GetOpt
#else
import GetOpt
#endif
-import System (getProgName, getArgs, ExitCode(..), exitWith, system)
+import System (getProgName, getArgs, ExitCode(..), exitWith)
import Directory (removeFile,doesFileExist)
import Monad (MonadPlus(..), liftM, liftM2, when)
import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
import List (intersperse, isSuffixOf)
import IO (hPutStr, hPutStrLn, stderr)
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS) && !__HUGS__
import Foreign
#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
import Foreign.C.String
#endif
+#if __GLASGOW_HASKELL__ >= 604
+import System.Process ( runProcess, waitForProcess )
+import System.IO ( openFile, IOMode(..), hClose )
+#define HAVE_runProcess
+#endif
+
#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
import Compat.RawSystem ( rawSystem )
-#elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+#define HAVE_rawSystem
+#elif __HUGS__ || __NHC__ >= 117
import System.Cmd ( rawSystem )
-#elif BUILD_NHC && __GLASGOW_HASKELL__ >= 603
-import Compat.RawSystem ( rawSystem )
+#define HAVE_rawSystem
+#endif
+
+#if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
+-- we need system
+#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+import System.Cmd ( system )
#else
-rawSystem prog args = system (prog++" "++unwords args)
+import System ( system )
+#endif
#endif
version :: String
-- 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
+ -- works on Win32 or Hugs (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
+#ifdef __HUGS__
+ do mb_path <- getExecDir "/Main.hs"
+#else
do mb_path <- getExecDir "/bin/hsc2hs.exe"
+#endif
add_opt <-
case mb_path of
Nothing -> return id
let cProgName = outDir++outBase++"_hsc_make.c"
oProgName = outDir++outBase++"_hsc_make.o"
progName = outDir++outBase++"_hsc_make"
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
-- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
-- via GHC has changed a few times, so this seems to be the only way... :-P * * *
++ ".exe"
fixChar c | isAlphaNum c = toUpper c
| otherwise = '_'
+#ifdef __HUGS__
+ compiler <- case [c | Compiler c <- flags] of
+ [] -> return "gcc"
+ [c] -> return c
+ _ -> onlyOne "compiler"
+
+ linker <- case [l | Linker l <- flags] of
+ [] -> return compiler
+ [l] -> return l
+ _ -> onlyOne "linker"
+#else
-- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
-- Returns a native-format path
locateGhc def = do
[] -> locateGhc compiler
[l] -> return l
_ -> onlyOne "linker"
+#endif
writeFile cProgName $
concatMap outFlagHeaderCProg flags++
_ -> return ()
removeFile oProgName
- progStatus <- systemL beVerbose (execProgName++" >"++outName)
+ progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
removeFile progName
case progStatus of
e@(ExitFailure _) -> exitWith e
-- NB. outHFile not outHName; works better when processed
-- by gcc or mkdependC.
-rawSystemL :: Bool -> String -> [String] -> IO ExitCode
+rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
rawSystemL flg prog args = do
- when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
+ let cmdLine = prog++" "++unwords args
+ when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
+#ifndef HAVE_rawSystem
+ system cmdLine
+#else
rawSystem prog args
+#endif
-systemL :: Bool -> String -> IO ExitCode
-systemL flg s = do
- when flg (hPutStrLn stderr ("Executing: " ++ s))
- system s
+rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
+rawSystemWithStdOutL flg prog args outFile = do
+ let cmdLine = prog++" "++unwords args++" >"++outFile
+ when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
+#ifndef HAVE_runProcess
+ system cmdLine
+#else
+ hOut <- openFile outFile WriteMode
+ process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
+ res <- waitForProcess process
+ hClose hOut
+ return res
+#endif
onlyOne :: String -> IO a
onlyOne what = die ("Only one "++what++" may be specified\n")
outFlagHeaderCProg :: Flag -> String
outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
outFlagHeaderCProg (Include f) = "#include "++f++"\n"
-outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
+outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
outFlagHeaderCProg _ = ""
"#endif\n"++
case inH of
Nothing -> concatMap outFlag flags++concatMap outSpecial toks
- Just f -> outOption ("-#include \""++f++"\"")
+ Just f -> outInclude ("\""++f++"\"")
where
- outFlag (Include f) = outOption ("-#include "++f)
+ outFlag (Include f) = outInclude f
outFlag (Define n Nothing) = outOption ("-optc-D"++n)
outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
outFlag _ = ""
outSpecial (pos, key, arg) = case key of
- "include" -> outOption ("-#include "++arg)
+ "include" -> outInclude arg
"define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
| otherwise -> ""
_ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
toOptD arg = case break isSpace arg of
(name, "") -> name
(name, _:value) -> name++'=':dropWhile isSpace value
- outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
- showCString s++"\");\n"
+ outOption s =
+ "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
+ " printf (\"{-# OPTIONS %s #-}\\n\", \""++
+ showCString s++"\");\n"++
+ "#else\n"++
+ " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
+ showCString s++"\");\n"++
+ "#endif\n"
+ outInclude s =
+ "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
+ " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
+ showCString s++"\");\n"++
+ "#else\n"++
+ " printf (\"{-# INCLUDE %s #-}\\n\", \""++
+ showCString s++"\");\n"++
+ "#endif\n"
outTokenHs :: Token -> String
outTokenHs (Text pos txt) =
outFlagH :: Flag -> String
outFlagH (Include f) = "#include "++f++"\n"
-outFlagH (Define n Nothing) = "#define "++n++"\n"
+outFlagH (Define n Nothing) = "#define "++n++" 1\n"
outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
outFlagH _ = ""
outHsLine :: SourcePos -> String
outHsLine (SourcePos name line) =
" hsc_line ("++show (line + 1)++", \""++
- showCString (snd (splitName name))++"\");\n"
+ showCString name++"\");\n"
showCString :: String -> String
showCString = concatMap showCChar
-----------------------------------------
--- Cut and pasted from ghc/compiler/SysTools
+-- Modified version 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 :: Char -> Char -> String -> String
+#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
+subst a b = map (\x -> if x == a then b else x)
+#else
+subst _ _ = id
+#endif
-subst :: Eq a => a -> a -> [a] -> [a]
-subst a b ls = map (\ x -> if x == a then b else x) ls
+dosifyPath :: String -> String
+dosifyPath = subst '/' '\\'
-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.
+getExecDir :: String -> IO (Maybe String)
+getExecDir cmd =
+ getExecPath >>= maybe (return Nothing) removeCmdSuffix
+ where unDosifyPath = subst '\\' '/'
+ initN n = reverse . drop n . reverse
+ removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
+
+getExecPath :: IO (Maybe String)
+#if defined(__HUGS__)
+getExecPath = liftM Just getProgName
+#elif defined(mingw32_HOST_OS)
+getExecPath =
+ allocaArray len $ \buf -> do
+ ret <- getModuleFileName nullPtr buf len
+ if ret == 0 then return Nothing
+ else liftM Just $ peekCString buf
+ where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+ getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
-dosifyPath xs = xs
-
-getExecDir :: String -> IO (Maybe String)
-getExecDir _ = return Nothing
+getExecPath = return Nothing
#endif
projects / ghc-hetmet.git / blobdiff