-{-# OPTIONS -cpp -fffi #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
#if __GLASGOW_HASKELL__ < 603
#include "config.h"
#else
-- 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:
module Main (main) where
-import System.Environment
-import System.IO
+import Control.Exception
+import Data.Char
import Data.List
+import Data.Monoid
+import Data.Version
+import System.Cmd
+import System.Directory
+import System.Environment
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
-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)
+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
+
+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 expr = "System.Environment.withProgName " ++ show filename ++
- " (System.Environment.withArgs " ++ show prog_args ++
- " (GHC.TopHandler.runIOFastExit" ++
- " (Main.main Prelude.>> Prelude.return ())))"
- 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).
+ -- 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"] ++
+ xflag ++
+ ghc_args ++
+ [ "-e", c1, "-e", c2, filename])
exitWith res
getGhcArgs :: [String] -> ([String], [String])
-getGhcArgs args = case break pastArgs args of
- (xs, "--":ys) -> (xs, ys)
- (xs, ys) -> (xs, ys)
+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 caes you need to use
+-- 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
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 =
+ 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
projects / ghc-hetmet.git / blobdiff