[project @ 2005-01-28 12:55:17 by simonmar]

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

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index bf77f9d..f6f8ecb 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,7 +1,7 @@
-{-# OPTIONS -fffi #-}
+{-# OPTIONS -fffi -cpp #-}

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

--- $Id: Main.hs,v 1.52 2004/02/09 17:23:20 ross Exp $
+-- $Id: Main.hs,v 1.69 2005/01/28 12:56:26 simonmar 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.

@@ -11,7 +11,11 @@
 --
 -- 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
+#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
 import System.Console.GetOpt
 #else
 import GetOpt

@@ -19,12 +23,12 @@ import GetOpt
 
 import System        (getProgName, getArgs, ExitCode(..), exitWith, system)
 import Directory     (removeFile,doesFileExist)
 
 import System        (getProgName, getArgs, ExitCode(..), exitWith, system)
 import Directory     (removeFile,doesFileExist)

-import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
+import Monad         (MonadPlus(..), liftM, liftM2, when)

 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 import IO            (hPutStr, hPutStrLn, stderr)
 
 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
 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String

@@ -34,6 +38,14 @@ import CString
 #endif
 
 
 #endif
 
 

+#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
+import Compat.RawSystem        ( rawSystem )
+#elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+import System.Cmd              ( rawSystem )
+#else
+rawSystem prog args = system (prog++" "++unwords args)
+#endif
+

 version :: String
 version = "hsc2hs version 0.66\n"
 
 version :: String
 version = "hsc2hs version 0.66\n"
 

@@ -104,12 +116,16 @@ main = do
 
        -- If there is no Template flag explicitly specified, try
        -- to find one by looking near the executable.  This only
 
        -- 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 
        -- 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"
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"

+#endif

                           add_opt <-
                            case mb_path of
                              Nothing   -> return id
                           add_opt <-
                            case mb_path of
                              Nothing   -> return id

@@ -478,14 +494,15 @@ output :: [Flag] -> String -> [Token] -> IO ()
 output flags name toks = do
     
     (outName, outDir, outBase) <- case [f | Output f <- flags] of
 output flags name toks = do
     
     (outName, outDir, outBase) <- case [f | Output f <- flags] of

-        []
-            | not (null ext) &&
-              last ext == 'c'   -> return (dir++base++init ext,  dir, base)
-            | ext == ".hs"      -> return (dir++base++"_out.hs", dir, base)
-            | otherwise         -> return (dir++base++".hs",     dir, base)
-            where
-            (dir,  file) = splitName name
-            (base, ext)  = splitExt  file
+        [] -> if not (null ext) && last ext == 'c'
+                 then return (dir++base++init ext,  dir, base)
+                 else
+                    if ext == ".hs"
+                       then return (dir++base++"_out.hs", dir, base)
+                       else return (dir++base++".hs",     dir, base)
+              where
+               (dir,  file) = splitName name
+               (base, ext)  = splitExt  file

         [f] -> let
             (dir,  file) = splitName f
             (base, _)    = splitExt file
         [f] -> let
             (dir,  file) = splitName f
             (base, _)    = splitExt file

@@ -494,12 +511,17 @@ 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" ++ EXEEXT
+        progName     = outDir++outBase++"_hsc_make"
+#if defined(mingw32_HOST_OS)
+-- 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"
+#endif

        outHFile     = outBase++"_hsc.h"
         outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
        
        outHFile     = outBase++"_hsc.h"
         outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
        

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

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

@@ -515,7 +537,19 @@ output flags name toks = do
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 

-          -- try locating GHC..on Win32, look in the vicinity of hsc2hs.
+#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
            mb <- getExecDir "bin/hsc2hs.exe"
            case mb of
         locateGhc def = do
            mb <- getExecDir "bin/hsc2hs.exe"
            case mb of

@@ -527,6 +561,16 @@ output flags name toks = do
                  then return ghc_path
                  else return def
     
                  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
     compiler <- case [c | Compiler c <- flags] of
         []  -> locateGhc "ghc"
         [c] -> return c

@@ -536,6 +580,7 @@ output flags name toks = do
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"

+#endif

 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++

@@ -546,26 +591,31 @@ output flags name toks = do
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
     
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
     

-    unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
+    -- 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 <- systemL beVerbose $
-        compiler++
-        " -c"++
-        concat [" "++f | CompFlag f <- flags]++
-        " "++cProgName++
-        " -o "++oProgName
+    compilerStatus <- rawSystemL beVerbose compiler
+       (  ["-c"]
+        ++ [f | CompFlag f <- flags]
+        ++ [cProgName]
+        ++ ["-o", oProgName]
+       )
+

     case compilerStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     removeFile cProgName
     
     case compilerStatus of
         e@(ExitFailure _) -> exitWith e
         _                 -> return ()
     removeFile cProgName
     

-    linkerStatus <- systemL beVerbose $
-        linker++
-        concat [" "++f | LinkFlag f <- flags]++
-        " "++oProgName++
-        " -o "++progName
+    linkerStatus <- rawSystemL beVerbose linker
+        (  [f | LinkFlag f <- flags]
+        ++ [oProgName]
+        ++ ["-o", progName]
+       )
+

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

@@ -578,17 +628,16 @@ output flags name toks = do
         _                 -> return ()
     
     when needsH $ writeFile outHName $
         _                 -> return ()
     
     when needsH $ writeFile outHName $

-        "#ifndef "++includeGuard++"\n\ 
-        \#define "++includeGuard++"\n\ 
-        \#if " ++
-       "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ 
-        \#include <Rts.h>\n\ 
-        \#endif\n\ 
-        \#include <HsFFI.h>\n\ 
-        \#if __NHC__\n\ 
-        \#undef HsChar\n\ 
-        \#define HsChar int\n\ 
-        \#endif\n"++
+        "#ifndef "++includeGuard++"\n" ++
+        "#define "++includeGuard++"\n" ++
+        "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
+        "#include <Rts.h>\n" ++
+        "#endif\n" ++
+        "#include <HsFFI.h>\n" ++
+        "#if __NHC__\n" ++
+        "#undef HsChar\n" ++
+        "#define HsChar int\n" ++
+        "#endif\n" ++

         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"

@@ -599,6 +648,11 @@ output flags name toks = do
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 
        -- NB. outHFile not outHName; works better when processed
        -- by gcc or mkdependC.
 

+rawSystemL :: Bool -> String -> [String] -> IO ExitCode
+rawSystemL flg prog args = do
+  when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args))
+  rawSystem prog args
+

 systemL :: Bool -> String -> IO ExitCode
 systemL flg s = do
   when flg (hPutStrLn stderr ("Executing: " ++ s))
 systemL :: Bool -> String -> IO ExitCode
 systemL flg s = do
   when flg (hPutStrLn stderr ("Executing: " ++ s))

@@ -610,7 +664,7 @@ 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 :: 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 _                     = ""
 
 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 outFlagHeaderCProg _                     = ""
 

@@ -629,20 +683,20 @@ outHeaderCProg (pos, key, arg) = case key of
         (header, _:body) -> case break isSpace header of
             (name, args) ->
                 outCLine pos++
         (header, _:body) -> case break isSpace header of
             (name, args) ->
                 outCLine pos++

-                "#define hsc_"++name++"("++dropWhile isSpace args++") \ 
-                \printf ("++joinLines body++");\n"
+                "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
+                "printf ("++joinLines body++");\n"

     _ -> ""
     _ -> ""

-    where
+   where

     joinLines = concat . intersperse " \\\n" . lines
 
 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 outHeaderHs flags inH toks =
     "#if " ++
     joinLines = concat . intersperse " \\\n" . lines
 
 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 outHeaderHs flags inH toks =
     "#if " ++

-    "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ 
-    \    printf (\"{-# OPTIONS -optc-D" ++
-    "__GLASGOW_HASKELL__=%d #-}\\n\", \ 
-    \__GLASGOW_HASKELL__);\n\ 
-    \#endif\n"++
+    "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
+    "    printf (\"{-# OPTIONS -optc-D" ++
+    "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
+    "__GLASGOW_HASKELL__);\n" ++
+    "#endif\n"++

     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
         Just f  -> outOption ("-#include \""++f++"\"")
     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
         Just f  -> outOption ("-#include \""++f++"\"")

@@ -700,19 +754,19 @@ outEnum arg =
                     (enum, rest) -> let
                         this = case break (== '=') $ dropWhile isSpace enum of
                             (name, []) ->
                     (enum, rest) -> let
                         this = case break (== '=') $ dropWhile isSpace enum of
                             (name, []) ->

-                                "    hsc_enum ("++t++", "++f++", \ 
-                                \hsc_haskellize (\""++name++"\"), "++
+                                "    hsc_enum ("++t++", "++f++", " ++
+                                "hsc_haskellize (\""++name++"\"), "++

                                 name++");\n"
                             (hsName, _:cName) ->
                                 name++");\n"
                             (hsName, _:cName) ->

-                                "    hsc_enum ("++t++", "++f++", \ 
-                                \printf (\"%s\", \""++hsName++"\"), "++
+                                "    hsc_enum ("++t++", "++f++", " ++
+                                "printf (\"%s\", \""++hsName++"\"), "++

                                 cName++");\n"
                         in this++enums rest
                 in enums afterF
 
 outFlagH :: Flag -> String
 outFlagH (Include  f)          = "#include "++f++"\n"
                                 cName++");\n"
                         in this++enums rest
                 in enums afterF
 
 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 _                     = ""
 
 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 outFlagH _                     = ""
 

@@ -726,12 +780,12 @@ outTokenH (pos, key, arg) =
             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
             'i':'n':'l':'i':'n':'e':' ':_ ->
             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
             'i':'n':'l':'i':'n':'e':' ':_ ->

-                "#ifdef __GNUC__\n\ 
-                \extern\n\ 
-                \#endif\n"++
+                "#ifdef __GNUC__\n" ++
+                "extern\n" ++
+                "#endif\n"++

                 arg++"\n"
             _ -> "extern "++header++";\n"
                 arg++"\n"
             _ -> "extern "++header++";\n"

-            where header = takeWhile (\c -> c /= '{' && c /= '=') arg
+          where header = takeWhile (\c -> c /= '{' && c /= '=') arg

         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 

@@ -745,13 +799,13 @@ outTokenC (pos, key, arg) =
                case span (\c -> c /= '{' && c /= '=') arg' of
                (header, body) ->
                    outCLine pos++
                case span (\c -> c /= '{' && c /= '=') arg' of
                (header, body) ->
                    outCLine pos++

-                   "#ifndef __GNUC__\n\ 
-                   \extern inline\n\ 
-                   \#endif\n"++
+                   "#ifndef __GNUC__\n" ++
+                   "extern inline\n" ++
+                   "#endif\n"++

                    header++
                    header++

-                   "\n#ifndef __GNUC__\n\ 
-                   \;\n\ 
-                   \#else\n"++
+                   "\n#ifndef __GNUC__\n" ++
+                   ";\n" ++
+                   "#else\n"++

                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"
                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"

@@ -804,21 +858,29 @@ showCString = concatMap showCChar
 --     Cut and pasted from ghc/compiler/SysTools
 -- Convert paths foo/baz to foo\baz on Windows
 
 --     Cut and pasted from ghc/compiler/SysTools
 -- Convert paths foo/baz to foo\baz on Windows
 

-dosifyPath :: String -> String
+dosifyPath, unDosifyPath :: String -> String

 #if defined(mingw32_HOST_OS)
 dosifyPath xs = subst '/' '\\' xs
 #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
 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

+#else
+dosifyPath xs = xs
+unDosifyPath xs = xs
+#endif

 
 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 :: 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

+#ifdef __HUGS__
+getExecDir cmd
+  = do
+       s <- getProgName
+       return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
+#elif defined(mingw32_HOST_OS)

 getExecDir cmd
   = allocaArray len $ \buf -> do
        ret <- getModuleFileName nullPtr buf len
 getExecDir cmd
   = allocaArray len $ \buf -> do
        ret <- getModuleFileName nullPtr buf len

@@ -833,8 +895,5 @@ foreign import stdcall unsafe "GetModuleFileNameA"
   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 
 #else
   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 
 #else

-dosifyPath xs = xs
-
-getExecDir :: String -> IO (Maybe String) 

 getExecDir _ = return Nothing
 #endif
 getExecDir _ = return Nothing
 #endif