merge GHC HEAD

[ghc-hetmet.git] / utils / runghc / runghc.hs

diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index bfdcc96..4424c96 100644 (file)
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -1,9 +1,5 @@
 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#else
 #include "ghcconfig.h"
-#endif
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow, 2004
@@ -23,8 +19,6 @@
 module Main (main) where
 
 import Control.Exception
-import Data.Char
-import Data.List
 import Data.Monoid
 import System.Cmd
 import System.Directory
@@ -44,6 +38,7 @@ main = do
     args <- getArgs
     case parseRunGhcFlags args of
         (Help, _) -> printUsage
+        (ShowVersion, _) -> printVersion
         (RunGhcFlags (Just ghc), args') -> doIt ghc args'
         (RunGhcFlags Nothing, args') -> do
             mbPath <- getExecPath
@@ -55,11 +50,14 @@ main = do
 
 data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
                  | Help -- Print help text
+                 | ShowVersion -- Print version info
 
 instance Monoid RunGhcFlags where
     mempty = RunGhcFlags Nothing
     Help `mappend` _ = Help
     _ `mappend` Help = Help
+    ShowVersion `mappend` _ = ShowVersion
+    _ `mappend` ShowVersion = ShowVersion
     RunGhcFlags _ `mappend` right@(RunGhcFlags (Just _)) = right
     left@(RunGhcFlags _) `mappend` RunGhcFlags Nothing = left
 
@@ -70,11 +68,16 @@ parseRunGhcFlags = f mempty
           f flags (('-' : 'f' : ghc) : args)
               = f (flags `mappend` RunGhcFlags (Just ghc)) args
           f flags ("--help" : args) = f (flags `mappend` Help) args
+          f flags ("--version" : args) = f (flags `mappend` ShowVersion) args
           -- If you need the first GHC flag to be a -f flag then
           -- you can pass -- first
           f flags ("--" : args) = (flags, args)
           f flags         args  = (flags, args)
 
+printVersion :: IO ()
+printVersion = do
+    putStrLn ("runghc " ++ VERSION)
+
 printUsage :: IO ()
 printUsage = do
     putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
@@ -82,6 +85,7 @@ printUsage = do
     putStrLn "The runghc flags are"
     putStrLn "    -f /path/to/ghc       Tell runghc where GHC is"
     putStrLn "    --help                Print this usage information"
+    putStrLn "    --version             Print version number"
 
 doIt :: String -> [String] -> IO ()
 doIt ghc args = do
@@ -145,15 +149,17 @@ dieProg msg = do
 
 getExecPath :: IO (Maybe String)
 #if defined(mingw32_HOST_OS)
-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
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap Just $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getExecPath = return Nothing
 #endif