[project @ 2004-08-12 12:12:54 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 8e758b6..b032553 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.53 2004/02/15 12:20:26 panne Exp $
+-- $Id: Main.hs,v 1.59 2004/08/12 12:12:54 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.

@@ -19,7 +19,7 @@ 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)

@@ -478,14 +478,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

@@ -504,7 +505,7 @@ output flags name toks = do
         outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
        
         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)

@@ -520,7 +521,8 @@ 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.
+        -- 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

@@ -532,6 +534,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

@@ -551,7 +563,10 @@ 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

 
 
     
 
 
     

@@ -583,17 +598,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"

@@ -634,20 +648,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++"\"")

@@ -705,12 +719,12 @@ 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
                                 cName++");\n"
                         in this++enums rest
                 in enums afterF

@@ -731,12 +745,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"
         _ -> ""
 

@@ -750,13 +764,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"