[project @ 2004-05-05 11:37:46 by simonmar]

Add the runghc program

diff --git a/ghc/utils/Makefile b/ghc/utils/Makefile
index 6ba0b79..7348160 100644 (file)
--- a/ghc/utils/Makefile
+++ b/ghc/utils/Makefile
@@ -8,7 +8,7 @@ else
 ifeq "$(BootingFromHc)" "YES"
 SUBDIRS = genapply genprimopcode ghc-pkg unlit
 else
-SUBDIRS = hasktags ghc-pkg hp2ps hsc2hs parallel stat2resid prof unlit genprimopcode genapply
+SUBDIRS = hasktags ghc-pkg hp2ps hsc2hs parallel stat2resid prof unlit genprimopcode genapply runghc
 endif
 endif
 

diff --git a/ghc/utils/runghc/Makefile b/ghc/utils/runghc/Makefile
new file mode 100644 (file)
index 0000000..5792902
--- /dev/null
+++ b/ghc/utils/runghc/Makefile
@@ -0,0 +1,7 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+HS_PROG                = runghc
+INSTALL_PROGS   += $(HS_PROG)
+
+include $(TOP)/mk/target.mk

diff --git a/ghc/utils/runghc/runghc.hs b/ghc/utils/runghc/runghc.hs
new file mode 100644 (file)
index 0000000..a79f411
--- /dev/null
+++ b/ghc/utils/runghc/runghc.hs
@@ -0,0 +1,79 @@
+{-# OPTIONS -cpp #-}
+#include "config.h"
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004
+--
+-- runghc program, for invoking from a #! line in a script.  For example:
+--
+--   script.lhs:
+--     #! /usr/bin/runghc
+--     > main = putStrLn "hello!"
+--
+-- runghc accepts one flag:
+--
+--     -f <path>    specify the path
+--
+-- -----------------------------------------------------------------------------
+
+module Main where
+
+import System.Environment
+import System.IO
+import System.Cmd
+import Data.List
+import System.Directory
+import System.Exit
+import Data.Char
+
+main = do 
+  args <- getArgs
+  case args of
+    ('-':'f' : ghc) : filename : args -> do
+       doIt (dropWhile isSpace ghc) filename args
+    filename : args -> do
+       path <- getEnv "PATH" `catch` \e -> return "."
+       ghc <- findBinary "ghc"
+       doIt ghc filename args
+    _other -> do
+       dieProg "syntax: runghc [-f GHCPATH] FILE ARG..."
+
+doIt ghc filename args = do
+  res <- rawSystem ghc ["-e","System.Environment.withArgs ["
+                       ++ concat (intersperse "," (map show args))
+                       ++ "] Main.main", filename]
+  exitWith res
+
+findBinary :: String -> IO FilePath
+findBinary binary = do
+  path <- getEnv "PATH"
+  search (parsePath path)
+  where
+    search :: [FilePath] -> IO FilePath
+    search [] = dieProg ("cannot find " ++ binary)
+    search (d:ds) = do
+       let path = d ++ '/':binary
+       b <- doesFileExist path
+       if b  then return path else search ds
+
+parsePath :: String -> [FilePath]
+parsePath path = split pathSep path
+  where
+#ifdef mingw32_TARGET_OS
+       pathSep = ';'
+#else
+       pathSep = ':'
+#endif
+
+split :: Char -> String -> [String]
+split c s = case rest of
+               []     -> [chunk] 
+               _:rest -> chunk : split c rest
+  where (chunk, rest) = break (==c) s
+
+die :: String -> IO a
+die msg = do hPutStr stderr msg; exitWith (ExitFailure 1)
+
+dieProg :: String -> IO a
+dieProg msg = do p <- getProgName; die (p ++ ": " ++ msg)
+