X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Frunghc%2Frunghc.hs;h=5a40b622de0c5fb61d4a4ad574d71d0f160ef1a9;hb=0f5e104c36b1dc3d8deeec5fef3d65e7b3a1b5ad;hp=9346390e30499ae7f8ca9b8151b648e571a24885;hpb=0a066666b10008aca3a875f5c7499c21c59efc0c;p=ghc-hetmet.git

diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index 9346390..5a40b62 100644
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -cpp -fffi #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
 #if __GLASGOW_HASKELL__ < 603
 #include "config.h"
 #else
@@ -27,56 +27,68 @@ import System.IO
 import Data.List
 import System.Exit
 import Data.Char
-
-#ifdef USING_COMPAT
-import Compat.RawSystem ( rawSystem )
-import Compat.Directory ( findExecutable )
-#else
+import System.Directory ( removeFile )
+import Control.Exception  ( bracket )
+import System.Directory ( findExecutable, getTemporaryDirectory )
 import System.Cmd       ( rawSystem )
-import System.Directory ( findExecutable )
-#endif
 
 main :: IO ()
 main = do
     args <- getArgs
-    case args of
-        ("-f" : ghc : args) -> do
-            doIt ghc args
-        ('-' : 'f' : ghc) : args -> do
-            doIt (dropWhile isSpace ghc) args
-        _ -> do
+    case getGhcLoc args of
+        (Just ghc, args') -> doIt ghc args'
+        (Nothing, args') -> do
             mb_ghc <- findExecutable "ghc"
             case mb_ghc of
                 Nothing  -> dieProg ("cannot find ghc")
-                Just ghc -> doIt ghc args
+                Just ghc -> doIt ghc args'
+
+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)
 
 doIt :: String -> [String] -> IO ()
 doIt ghc args = do
-    let (ghc_args, rest) = break notArg args
+    let (ghc_args, rest) = getGhcArgs args
     case rest of
-        [] -> dieProg "syntax: runghc [-f GHCPATH] [GHC-ARGS] FILE ARG..."
+        [] -> do
+           -- behave like typical perl, python, ruby interpreters:      
+           -- read from stdin
+           tmpdir <- getTemporaryDirectory
+           bracket
+             (openTempFile tmpdir "runghcXXXX.hs")
+             (\(filename,_) -> removeFile filename)
+             $ \(filename,h) -> do
+                 getContents >>= hPutStr h
+                 hClose h
+                 doIt ghc (ghc_args ++ [filename])
         filename : prog_args -> do
-            let expr = "System.Environment.withProgName " ++ show filename ++
-                       " (System.Environment.withArgs " ++ show prog_args ++
-                       " (GHC.TopHandler.runIOFastExit" ++
-                       " (Main.main Prelude.>> Prelude.return ())))"
+            let c1 = ":set prog " ++ show filename
+                c2 = ":main " ++ show prog_args
             res <- rawSystem ghc (["-ignore-dot-ghci"] ++ ghc_args ++
-                                  [ "-e", expr, filename])
-               -- runIOFastExit: makes exceptions raised by Main.main
-               -- behave in the same way as for a compiled program.
-               -- The "fast exit" part just calls exit() directly
-               -- instead of doing an orderly runtime shutdown,
-               -- otherwise the main GHCi thread will complain about
-               -- being interrupted.
-               --
-               -- Why (main >> return ()) rather than just main?  Because
-               -- otherwise GHCi by default tries to evaluate the result
-               -- of the IO in order to show it (see #1200).
+                                  [ "-e", c1, "-e", c2, filename])
             exitWith res
 
-notArg :: String -> Bool
-notArg ('-':_) = False
-notArg _       = True
+getGhcArgs :: [String] -> ([String], [String])
+getGhcArgs args
+ = let (ghcArgs, otherArgs) = case break pastArgs args of
+                              (xs, "--":ys) -> (xs, ys)
+                              (xs, ys)      -> (xs, ys)
+   in (map unescape ghcArgs, otherArgs)
+    where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
+          unescape arg = arg
+
+pastArgs :: String -> Bool
+-- You can use -- to mark the end of the flags, in case you need to use
+-- a file called -foo.hs for some reason. You almost certainly shouldn't,
+-- though.
+pastArgs "--" = True
+pastArgs ('-':_) = False
+pastArgs _       = True
 
 dieProg :: String -> IO a
 dieProg msg = do
@@ -84,3 +96,6 @@ dieProg msg = do
     hPutStrLn stderr (p ++ ": " ++ msg)
     exitWith (ExitFailure 1)
 
+-- usage :: String
+-- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
+