From: Ian Lynagh <igloo@earth.li>
Date: Wed, 23 Jul 2008 18:11:15 +0000 (+0000)
Subject: runghc now uses the compiler that it comes with; fixes trac #1281
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f373efd4e3ca479a9a366604a7adbf055e37ee63

runghc now uses the compiler that it comes with; fixes trac #1281
rather than the first one that it finds on the PATH
---

diff --git a/utils/runghc/Makefile b/utils/runghc/Makefile
index 37e2a1d..0b606de 100644
--- a/utils/runghc/Makefile
+++ b/utils/runghc/Makefile
@@ -1,5 +1,7 @@
 
 TOP=../..
+ENABLE_SHELL_WRAPPERS = YES
+
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/cabal.mk
 
diff --git a/utils/runghc/runghc.cabal b/utils/runghc/runghc.cabal
index 17ed923..c3620de 100644
--- a/utils/runghc/runghc.cabal
+++ b/utils/runghc/runghc.cabal
@@ -25,4 +25,5 @@ Executable runghc
                        process    >= 1   && < 1.1
     else
         Build-Depends: base < 3
+    Build-Depends: filepath
 
diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index 5a40b62..84675bc 100644
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -11,7 +11,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,15 +22,15 @@
 
 module Main (main) where
 
-import System.Environment
-import System.IO
+import Control.Exception
+import Data.Char
 import Data.List
+import System.Cmd
+import System.Directory
+import System.Environment
 import System.Exit
-import Data.Char
-import System.Directory ( removeFile )
-import Control.Exception  ( bracket )
-import System.Directory ( findExecutable, getTemporaryDirectory )
-import System.Cmd       ( rawSystem )
+import System.FilePath
+import System.IO
 
 main :: IO ()
 main = do
@@ -38,25 +38,34 @@ main = do
     case getGhcLoc args of
         (Just ghc, args') -> doIt ghc args'
         (Nothing, args') -> do
-            mb_ghc <- findExecutable "ghc"
-            case mb_ghc of
+            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'
 
 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)
+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)
+                 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
 
 doIt :: String -> [String] -> IO ()
 doIt ghc args = do
     let (ghc_args, rest) = getGhcArgs args
     case rest of
         [] -> do
-           -- behave like typical perl, python, ruby interpreters:      
+           -- behave like typical perl, python, ruby interpreters:
            -- read from stdin
            tmpdir <- getTemporaryDirectory
            bracket
@@ -99,3 +108,18 @@ dieProg msg = do
 -- usage :: String
 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
 
+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
+#else
+getExecPath = return Nothing
+#endif
+