merge GHC HEAD

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

diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index 5baaeff..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,7 @@
 module Main (main) where
 
 import Control.Exception
-import Data.Char
-import Data.List
+import Data.Monoid
 import System.Cmd
 import System.Directory
 import System.Environment
@@ -41,9 +36,11 @@ import Foreign.C.String
 main :: IO ()
 main = do
     args <- getArgs
-    case getGhcLoc args of
-        (Just ghc, args') -> doIt ghc args'
-        (Nothing, args') -> do
+    case parseRunGhcFlags args of
+        (Help, _) -> printUsage
+        (ShowVersion, _) -> printVersion
+        (RunGhcFlags (Just ghc), args') -> doIt ghc args'
+        (RunGhcFlags Nothing, args') -> do
             mbPath <- getExecPath
             case mbPath of
                 Nothing  -> dieProg ("cannot find ghc")
@@ -51,20 +48,44 @@ main = do
                     let ghc = takeDirectory (normalise path) </> "ghc"
                     in doIt ghc args'
 
-getGhcLoc :: [String] -> (Maybe FilePath, [String])
-getGhcLoc args = case args of
-                 "-f" : ghc : args' -> f ghc args'
-                 ('-' : 'f' : ghc) : args' -> f ghc args'
-                 -- If you need the first GHC flag to be a -f flag then
-                 -- you can pass -- first
-                 "--" : args' -> (Nothing, args')
-                 _            -> (Nothing, args)
-    where f ghc args' = -- If there is another -f flag later on then
-                        -- that overrules the one that we've already
-                        -- found
-                        case getGhcLoc args' of
-                        (Nothing, _) -> (Just ghc, args')
-                        success -> success
+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
+
+parseRunGhcFlags :: [String] -> (RunGhcFlags, [String])
+parseRunGhcFlags = f mempty
+    where f flags ("-f" : ghc : args)
+              = f (flags `mappend` RunGhcFlags (Just ghc)) args
+          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]"
+    putStrLn ""
+    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
@@ -128,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