X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Frunghc%2Frunghc.hs;h=aadafd9a7125ef28785770e74294187b4badc429;hp=f8330b5721363fb540cced05355d274dda3c69cb;hb=34cc75e1a62638f2833815746ebce0a9114dc26b;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs index f8330b5..aadafd9 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 @@ -11,56 +11,161 @@ -- runghc program, for invoking from a #! line in a script. For example: -- -- script.lhs: --- #! /usr/bin/runghc --- > main = putStrLn "hello!" +-- #!/usr/bin/env /usr/bin/runghc +-- > main = putStrLn "hello!" -- -- runghc accepts one flag: -- --- -f specify the path +-- -f specify the path -- -- ----------------------------------------------------------------------------- -module Main where +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 + +#if defined(mingw32_HOST_OS) +import Control.Monad +import Foreign +import Foreign.C.String +#endif + +main :: IO () +main = do + args <- getArgs + 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 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 -import Compat.RawSystem ( rawSystem ) -import Compat.Directory ( findExecutable ) +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 -main = do - args <- getArgs - case args of - ('-':'f' : ghc) : args -> do - doIt (dropWhile isSpace ghc) args - args -> do - mb_ghc <- findExecutable "ghc" - case mb_ghc of - Nothing -> dieProg ("cannot find ghc") - Just ghc -> doIt ghc args +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) = break notArg args - -- - case rest of - [] -> dieProg "syntax: runghc [-f GHCPATH] [GHC-ARGS] FILE ARG..." - filename : prog_args -> do - res <- rawSystem ghc ( - "-ignore-dot-ghci" : ghc_args ++ - [ "-e","System.Environment.withProgName "++show filename++" (System.Environment.withArgs [" - ++ concat (intersperse "," (map show prog_args)) - ++ "] Main.main)", filename]) - exitWith res - -notArg ('-':_) = False -notArg _ = True + let (ghc_args, rest) = getGhcArgs args + case rest of + [] -> 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 + -- 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 + = 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 - p <- getProgName - hPutStrLn stderr (p ++ ": " ++ msg) - exitWith (ExitFailure 1) + p <- getProgName + hPutStrLn stderr (p ++ ": " ++ msg) + exitWith (ExitFailure 1) + +-- 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 +