From: simonmar <unknown>
Date: Wed, 5 May 2004 11:37:46 +0000 (+0000)
Subject: [project @ 2004-05-05 11:37:46 by simonmar]
X-Git-Tag: Initial_conversion_from_CVS_complete~1876
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c1f0366b19ddba81a0e35c4204502432286d77d9;p=ghc-hetmet.git

[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
--- 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
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
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)
+