-{-# OPTIONS -fffi -cpp #-}
+{-# OPTIONS -cpp #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
------------------------------------------------------------------------
-- Program for converting .hsc files to .hs files, by converting the
#include "../../includes/ghcconfig.h"
#endif
-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
+import Control.Monad ( MonadPlus(..), liftM, liftM2, when )
+import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit,
+ toUpper, intToDigit, ord )
+import Data.List ( intersperse, isSuffixOf )
+import System.Cmd ( system, rawSystem )
import System.Console.GetOpt
-#else
-import GetOpt
-#endif
-
-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) && !__HUGS__
+#if defined(mingw32_HOST_OS)
import Foreign
-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
import Foreign.C.String
-#else
-import CString
-#endif
#endif
-
+import System.Directory ( removeFile, doesFileExist, findExecutable )
+import System.Environment ( getProgName, getArgs )
+import System.Exit ( ExitCode(..), exitWith )
+import System.IO ( hPutStr, hPutStrLn, stderr )
#if __GLASGOW_HASKELL__ >= 604
import System.Process ( runProcess, waitForProcess )
#define HAVE_runProcess
#endif
-#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
-import Compat.RawSystem ( rawSystem )
-#define HAVE_rawSystem
-#elif __HUGS__ || __NHC__ >= 117
-import System.Cmd ( rawSystem )
-#define HAVE_rawSystem
-#endif
+import IO ( bracket_ )
+import Distribution.Text
-#if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
--- we need system
-#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
-import System.Cmd ( system )
+#if ! BUILD_NHC
+import Paths_hsc2hs ( getDataFileName, version )
+import Data.Version ( showVersion )
#else
-import System ( system )
+import System.Directory ( getCurrentDirectory )
+getDataFileName s = do here <- getCurrentDirectory
+ return (here++"/"++s)
+version = "0.67" -- TODO!!!
+showVersion = id
#endif
+
+#ifdef __GLASGOW_HASKELL__
+default_compiler = "ghc"
+#else
+default_compiler = "gcc"
#endif
-version :: String
-version = "hsc2hs version 0.66\n"
+versionString :: String
+versionString = "hsc2hs version " ++ showVersion version ++ "\n"
data Flag
= Help
"display this help and exit",
Option ['V'] ["version"] (NoArg Version)
"output version information and exit" ]
-
main :: IO ()
main = do
args <- getArgs
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 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
- 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)
+ -- If there is no Template flag explicitly specified, try
+ -- to find one. We first look near the executable. This only
+ -- works on Win32 or Hugs (getExecDir). If this finds a template
+ -- file then it's certainly the one we want, even if hsc2hs isn't
+ -- installed where we told Cabal it would be installed.
+ --
+ -- Next we try the location we told Cabal about.
+ --
+ -- If neither of the above work, then hopefully we're on Unix and
+ -- there's a wrapper script which specifies an explicit template flag.
+ flags_w_tpl0 <-
+ if any template_flag flags then return flags
+ else do mb_path <- getExecDir "/bin/hsc2hs.exe"
+ mb_templ1 <-
+ case mb_path of
+ Nothing -> return Nothing
+ Just path -> do
+ -- Euch, this is horrible. Unfortunately
+ -- Paths_hsc2hs isn't too useful for a
+ -- relocatable binary, though.
+ let templ1 = path ++ "/hsc2hs-" ++ display Paths_hsc2hs.version ++ "/template-hsc.h"
+ exists1 <- doesFileExist templ1
+ if exists1
+ then return (Just templ1)
+ else return Nothing
+ case mb_templ1 of
+ Just templ1 -> return (Template templ1 : flags)
+ Nothing -> do
+ templ2 <- getDataFileName "template-hsc.h"
+ exists2 <- doesFileExist templ2
+ if exists2 then return (Template templ2 : flags)
+ else return flags
+
+ -- take only the last --template flag on the cmd line
+ let
+ (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
+ flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
+
case (files, errs) of
(_, _)
| any isHelp flags_w_tpl -> bye (usageInfo header options)
- | any isVersion flags_w_tpl -> bye version
+ | any isVersion flags_w_tpl -> bye versionString
where
isHelp Help = True; isHelp _ = False
isVersion Version = True; isVersion _ = False
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
processFile :: [Flag] -> String -> IO ()
-processFile flags name
+processFile flags name
= do let file_name = dosifyPath name
s <- readFile file_name
case parser of
output :: [Flag] -> String -> [Token] -> IO ()
output flags name toks = do
-
+
(outName, outDir, outBase) <- case [f | Output f <- flags] of
[] -> if not (null ext) && last ext == 'c'
then return (dir++base++init ext, dir, base)
(base, _) = splitExt file
in return (f, dir, base)
_ -> onlyOne "output file"
-
+
let cProgName = outDir++outBase++"_hsc_make.c"
oProgName = outDir++outBase++"_hsc_make.o"
progName = outDir++outBase++"_hsc_make"
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 = dosifyPath ("./" ++ progName)
| otherwise = progName
-
+
let specials = [(pos, key, arg) | Special pos key arg <- toks]
-
+
let needsC = any (\(_, key, _) -> key == "def") specials
needsH = needsC
-
+
let includeGuard = map fixChar outHName
where
fixChar c | isAlphaNum c = toUpper c
| otherwise = '_'
-#ifdef __HUGS__
compiler <- case [c | Compiler c <- flags] of
- [] -> return "gcc"
- [c] -> return c
- _ -> onlyOne "compiler"
-
+ [] -> do
+ mb_path <- findExecutable default_compiler
+ case mb_path of
+ Nothing -> die ("Can't find "++default_compiler++"\n")
+ Just path -> return path
+ cs -> return (last cs)
+
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
- 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
-
- -- On a Win32 installation we execute the hsc2hs binary directly,
- -- with no --cc flags, so we'll call locateGhc here, which will
- -- succeed, via getExecDir.
- --
- -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
- -- (called plain hsc2hs in the installed tree), which will pass
- -- a suitable C compiler via --cc
- --
- -- The in-place installation always uses the wrapper script,
- -- (called hsc2hs-inplace, generated from hsc2hs.sh)
- compiler <- case [c | Compiler c <- flags] of
- [] -> locateGhc "ghc"
- [c] -> return c
- _ -> onlyOne "compiler"
-
- linker <- case [l | Linker l <- flags] of
- [] -> locateGhc compiler
- [l] -> return l
- _ -> onlyOne "linker"
-#endif
+ ls -> return (last ls)
writeFile cProgName $
concatMap outFlagHeaderCProg flags++
outHsLine (SourcePos name 0)++
concatMap outTokenHs toks++
" return 0;\n}\n"
-
+
-- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
-- so we use something slightly more complicated. :-P
when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
exitWith ExitSuccess
-
-
- compilerStatus <- rawSystemL beVerbose compiler
+ rawSystemL ("compiling " ++ cProgName) beVerbose compiler
( ["-c"]
++ [f | CompFlag f <- flags]
++ [cProgName]
++ ["-o", oProgName]
)
+ finallyRemove cProgName $ do
- case compilerStatus of
- e@(ExitFailure _) -> exitWith e
- _ -> return ()
- removeFile cProgName
-
- linkerStatus <- rawSystemL beVerbose linker
+ rawSystemL ("linking " ++ oProgName) beVerbose linker
( [f | LinkFlag f <- flags]
++ [oProgName]
++ ["-o", progName]
)
+ finallyRemove oProgName $ do
+
+ rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
+ finallyRemove progName $ do
- case linkerStatus of
- e@(ExitFailure _) -> exitWith e
- _ -> return ()
- removeFile oProgName
-
- progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
- removeFile progName
- case progStatus of
- e@(ExitFailure _) -> exitWith e
- _ -> return ()
-
when needsH $ writeFile outHName $
"#ifndef "++includeGuard++"\n" ++
"#define "++includeGuard++"\n" ++
concatMap outFlagH flags++
concatMap outTokenH specials++
"#endif\n"
-
+
when needsC $ writeFile outCName $
"#include \""++outHFile++"\"\n"++
concatMap outTokenC specials
-- NB. outHFile not outHName; works better when processed
-- by gcc or mkdependC.
-rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
-rawSystemL flg prog args = do
+rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
+rawSystemL action flg prog args = do
let cmdLine = prog++" "++unwords args
when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
-#ifndef HAVE_rawSystem
- system cmdLine
-#else
- rawSystem prog args
-#endif
+ exitStatus <- rawSystem prog args
+ case exitStatus of
+ ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
+ _ -> return ()
-rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
-rawSystemWithStdOutL flg prog args outFile = do
+rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
+rawSystemWithStdOutL action flg prog args outFile = do
let cmdLine = prog++" "++unwords args++" >"++outFile
when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
#ifndef HAVE_runProcess
- system cmdLine
+ exitStatus <- system cmdLine
#else
hOut <- openFile outFile WriteMode
process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
- res <- waitForProcess process
+ exitStatus <- waitForProcess process
hClose hOut
- return res
#endif
+ case exitStatus of
+ ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
+ _ -> return ()
+
+-- delay the cleanup of generated files until the end; attempts to
+-- get around intermittent failure to delete files which has
+-- just been exec'ed by a sub-process (Win32 only.)
+finallyRemove :: FilePath -> IO a -> IO a
+finallyRemove fp act =
+ bracket_ (return fp)
+ (const $ noisyRemove fp)
+ act
+ where
+ noisyRemove fpath =
+ catch (removeFile fpath)
+ (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
onlyOne :: String -> IO a
onlyOne what = die ("Only one "++what++" may be specified\n")
intToDigit (ord c `quot` 8 `mod` 8),
intToDigit (ord c `mod` 8)]
-
-
-----------------------------------------
-- Modified version from ghc/compiler/SysTools
-- Convert paths foo/baz to foo\baz on Windows
dosifyPath = subst '/' '\\'
-- (getExecDir cmd) returns the directory in which the current
--- executable, which should be called 'cmd', is running
+-- 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 :: String -> IO (Maybe String)
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
getExecPath :: IO (Maybe String)
-#if defined(__HUGS__)
-getExecPath = liftM Just getProgName
-#elif defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS)
getExecPath =
allocaArray len $ \buf -> do
ret <- getModuleFileName nullPtr buf len
#else
getExecPath = return Nothing
#endif
+
projects / ghc-hetmet.git / blobdiff