[project @ 2004-02-09 15:04:19 by malcolm]

[ghc-hetmet.git] / ghc / utils / hsc2hs / Main.hs

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index a2ba3f6..9c5e9eb 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,5 +1,7 @@
+{-# OPTIONS -fglasgow-exts #-}
+

 ------------------------------------------------------------------------
 ------------------------------------------------------------------------

--- $Id: Main.hs,v 1.33 2001/09/12 11:16:05 rrt Exp $
+-- $Id: Main.hs,v 1.51 2004/02/09 15:04:19 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.
 --
 -- 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.
 
 --
 -- See the documentation in the Users' Guide for more details.
 

+#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
+import System.Console.GetOpt
+#else

 import GetOpt
 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 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

+#endif
+

 
 version :: String
 
 version :: String

-version = "hsc2hs-0.65"
+version = "hsc2hs version 0.66\n"

 
 data Flag
     = Help
 
 data Flag
     = Help

@@ -38,6 +49,11 @@ data Flag
     | Include   String
     | Define    String (Maybe String)
     | Output    String
     | 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
 
 include :: String -> Flag
 include s@('\"':_) = Include s

@@ -51,56 +67,90 @@ define s = case break (== '=') s of
 
 options :: [OptDescr Flag]
 options = [
 
 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
 
 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
     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 (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
             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 :: [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.
 
 ------------------------------------------------------------------------
 -- 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"
     
     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"
         outCName     = outDir++outBase++"_hsc.c"

+       
+       beVerbose    = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags

 
     let execProgName
 
     let execProgName

-            | null outDir = "./"++progName
+            | null outDir = dosifyPath ("./" ++ progName)

             | otherwise   = progName
     
     let specials = [(pos, key, arg) | Special pos key arg <- toks]
             | 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    = '_'
             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
     
     compiler <- case [c | Compiler c <- flags] of

-        []  -> return "ghc"
+        []  -> locateGhc "ghc"

         [c] -> return c
         _   -> onlyOne "compiler"
     
     linker <- case [l | Linker l <- flags] of
         [c] -> return c
         _   -> onlyOne "compiler"
     
     linker <- case [l | Linker l <- flags] of

-        []  -> return defaultCompiler
+        []  -> locateGhc compiler

         [l] -> return l
         _   -> onlyOne "linker"
         [l] -> return l
         _   -> onlyOne "linker"

-    
+

     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
         concatMap outHeaderCProg specials++
     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
         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]++
         compiler++
         " -c"++
         concat [" "++f | CompFlag f <- flags]++

@@ -494,7 +561,7 @@ output flags name toks = do
         _                 -> return ()
     removeFile cProgName
     
         _                 -> return ()
     removeFile cProgName
     

-    linkerStatus <- system $
+    linkerStatus <- systemL beVerbose $

         linker++
         concat [" "++f | LinkFlag f <- flags]++
         " "++oProgName++
         linker++
         concat [" "++f | LinkFlag f <- flags]++
         " "++oProgName++

@@ -504,8 +571,11 @@ output flags name toks = do
         _                 -> return ()
     removeFile oProgName
     
         _                 -> return ()
     removeFile oProgName
     

-    system (execProgName++" >"++outName)
+    progStatus <- systemL beVerbose (execProgName++" >"++outName)

     removeFile progName
     removeFile progName

+    case progStatus of
+        e@(ExitFailure _) -> exitWith e
+        _                 -> return ()

     
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n\ 
     
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n\ 

@@ -524,13 +594,18 @@ output flags name toks = do
         "#endif\n"
     
     when needsC $ writeFile outCName $
         "#endif\n"
     
     when needsC $ writeFile outCName $

-        "#include \""++outHName++"\"\n"++
+        "#include \""++outHFile++"\"\n"++

         concatMap outTokenC specials
         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 :: 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"
 
 outFlagHeaderCProg :: Flag -> String
 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"

@@ -594,9 +669,9 @@ outHeaderHs flags inH toks =
                   showCString s++"\");\n"
 
 outTokenHs :: Token -> String
                   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++
         (first, _:rest) ->
             outText (first++"\n")++
             outHsLine pos++

@@ -696,7 +771,7 @@ conditional _         = False
 
 outCLine :: SourcePos -> String
 outCLine (SourcePos name line) =
 
 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) =
 
 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)]
                       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 "GetModuleFileNameA" unsafe
+  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+
+#else
+dosifyPath xs = xs
+
+getExecDir :: String -> IO (Maybe String) 
+getExecDir _ = return Nothing
+#endif