{-# OPTIONS -fffi -cpp #-}
------------------------------------------------------------------------
--- $Id: Main.hs,v 1.68 2005/01/27 12:38:49 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.
-- Certain items known only to the C compiler can then be used in
--
-- See the documentation in the Users' Guide for more details.
+#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)
#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 )
+#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
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"
_ -> 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")
"#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) =
-----------------------------------------
--- Cut and pasted from ghc/compiler/SysTools
+-- Modified version from ghc/compiler/SysTools
-- Convert paths foo/baz to foo\baz on Windows
-dosifyPath, unDosifyPath :: String -> String
-#if defined(mingw32_HOST_OS)
-dosifyPath xs = subst '/' '\\' xs
-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
+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
-dosifyPath xs = xs
-unDosifyPath xs = xs
+subst _ _ = id
#endif
-getExecDir :: String -> IO (Maybe String)
+dosifyPath :: String -> String
+dosifyPath = subst '/' '\\'
+
-- (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
-#ifdef __HUGS__
-getExecDir cmd
- = do
- s <- getProgName
- return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
+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)
-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.
+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
-getExecDir _ = return Nothing
+getExecPath = return Nothing
#endif
projects / ghc-hetmet.git / blobdiff