X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Frunghc%2Frunghc.hs;h=4424c96096332d4c594d73c008f19ffe842d1ef3;hp=244c98f972c41dd78d8ff825bdce12a58d79412c;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=c38ec601e46f02a6cbd907eb5f796cb83fac3ed4

diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index 244c98f..4424c96 100644
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -1,9 +1,5 @@
-{-# OPTIONS -cpp -fffi #-}
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#else
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
 #include "ghcconfig.h"
-#endif
 -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow, 2004
@@ -11,7 +7,7 @@
 -- runghc program, for invoking from a #! line in a script.  For example:
 --
 --   script.lhs:
---      #! /usr/bin/runghc
+--      #!/usr/bin/env /usr/bin/runghc
 --      > main = putStrLn "hello!"
 --
 -- runghc accepts one flag:
@@ -22,48 +18,106 @@
 
 module Main (main) where
 
+import Control.Exception
+import Data.Monoid
+import System.Cmd
+import System.Directory
 import System.Environment
-import System.IO
-import Data.List
 import System.Exit
-import Data.Char
+import System.FilePath
+import System.IO
 
-#ifdef USING_COMPAT
-import Compat.RawSystem ( rawSystem )
-import Compat.Directory ( findExecutable )
-#else
-import System.Cmd       ( rawSystem )
-import System.Directory ( findExecutable )
+#if defined(mingw32_HOST_OS)
+import Control.Monad
+import Foreign
+import Foreign.C.String
 #endif
 
 main :: IO ()
 main = do
     args <- getArgs
-    case getGhcLoc args of
-        (Just ghc, args') -> doIt ghc args'
-        (Nothing, args') -> do
-            mb_ghc <- findExecutable "ghc"
-            case mb_ghc of
+    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")
-                Just ghc -> doIt ghc args'
+                Just path ->
+                    let ghc = takeDirectory (normalise path) </> "ghc"
+                    in doIt ghc args'
+
+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
 
-getGhcLoc :: [String] -> (Maybe FilePath, [String])
-getGhcLoc ("-f" : ghc : args) = (Just ghc, args)
-getGhcLoc (('-' : 'f' : ghc) : args) = (Just ghc, args)
--- If you need the first GHC flag to be a -f flag then you can pass --
--- first
-getGhcLoc ("--" : args) = (Nothing, args)
-getGhcLoc args = (Nothing, args)
+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
     let (ghc_args, rest) = getGhcArgs args
     case rest of
-        [] -> dieProg usage
+        [] -> do
+           -- behave like typical perl, python, ruby interpreters:
+           -- read from stdin
+           tmpdir <- getTemporaryDirectory
+           bracket
+             (openTempFile tmpdir "runghcXXXX.hs")
+             (\(filename,h) -> do hClose h; removeFile filename)
+             $ \(filename,h) -> do
+                 getContents >>= hPutStr h
+                 hClose h
+                 doIt ghc (ghc_args ++ [filename])
         filename : prog_args -> do
-            let c1 = ":set prog " ++ show filename
+            -- If the file exists, and is not a .lhs file, then we
+            -- want to treat it as a .hs file.
+            --
+            -- If the file doesn't exist then GHC is going to look for
+            -- filename.hs and filename.lhs, and use the appropriate
+            -- type.
+            exists <- doesFileExist filename
+            let xflag = if exists && (takeExtension filename /= ".lhs")
+                        then ["-x", "hs"]
+                        else []
+                c1 = ":set prog " ++ show filename
                 c2 = ":main " ++ show prog_args
-            res <- rawSystem ghc (["-ignore-dot-ghci"] ++ ghc_args ++
+            res <- rawSystem ghc (["-ignore-dot-ghci"] ++
+                                  xflag ++
+                                  ghc_args ++
                                   [ "-e", c1, "-e", c2, filename])
             exitWith res
 
@@ -90,6 +144,23 @@ dieProg msg = do
     hPutStrLn stderr (p ++ ": " ++ msg)
     exitWith (ExitFailure 1)
 
-usage :: String
-usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
+-- usage :: String
+-- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
+
+getExecPath :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
+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