Remove some of the old compat stuff now that we assume GHC 6.4
[ghc.git] / utils / runghc / runghc.hs
1 {-# OPTIONS -cpp -fffi #-}
2 #if __GLASGOW_HASKELL__ < 603
3 #include "config.h"
4 #else
5 #include "ghcconfig.h"
6 #endif
7 -----------------------------------------------------------------------------
8 --
9 -- (c) The University of Glasgow, 2004
10 --
11 -- runghc program, for invoking from a #! line in a script. For example:
12 --
13 -- script.lhs:
14 -- #! /usr/bin/runghc
15 -- > main = putStrLn "hello!"
16 --
17 -- runghc accepts one flag:
18 --
19 -- -f <path> specify the path
20 --
21 -- -----------------------------------------------------------------------------
22
23 module Main (main) where
24
25 import System.Environment
26 import System.IO
27 import Data.List
28 import System.Exit
29 import Data.Char
30 import System.Directory ( removeFile )
31 import Control.Exception ( bracket )
32 import System.Directory ( findExecutable, getTemporaryDirectory )
33 import System.Cmd ( rawSystem )
34
35 main :: IO ()
36 main = do
37 args <- getArgs
38 case getGhcLoc args of
39 (Just ghc, args') -> doIt ghc args'
40 (Nothing, args') -> do
41 mb_ghc <- findExecutable "ghc"
42 case mb_ghc of
43 Nothing -> dieProg ("cannot find ghc")
44 Just ghc -> doIt ghc args'
45
46 getGhcLoc :: [String] -> (Maybe FilePath, [String])
47 getGhcLoc ("-f" : ghc : args) = (Just ghc, args)
48 getGhcLoc (('-' : 'f' : ghc) : args) = (Just ghc, args)
49 -- If you need the first GHC flag to be a -f flag then you can pass --
50 -- first
51 getGhcLoc ("--" : args) = (Nothing, args)
52 getGhcLoc args = (Nothing, args)
53
54 doIt :: String -> [String] -> IO ()
55 doIt ghc args = do
56 let (ghc_args, rest) = getGhcArgs args
57 case rest of
58 [] -> do
59 -- behave like typical perl, python, ruby interpreters:
60 -- read from stdin
61 tmpdir <- getTemporaryDirectory
62 bracket
63 (openTempFile tmpdir "runghcXXXX.hs")
64 (\(filename,_) -> removeFile filename)
65 $ \(filename,h) -> do
66 getContents >>= hPutStr h
67 hClose h
68 doIt ghc (ghc_args ++ [filename])
69 filename : prog_args -> do
70 let c1 = ":set prog " ++ show filename
71 c2 = ":main " ++ show prog_args
72 res <- rawSystem ghc (["-ignore-dot-ghci"] ++ ghc_args ++
73 [ "-e", c1, "-e", c2, filename])
74 exitWith res
75
76 getGhcArgs :: [String] -> ([String], [String])
77 getGhcArgs args
78 = let (ghcArgs, otherArgs) = case break pastArgs args of
79 (xs, "--":ys) -> (xs, ys)
80 (xs, ys) -> (xs, ys)
81 in (map unescape ghcArgs, otherArgs)
82 where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
83 unescape arg = arg
84
85 pastArgs :: String -> Bool
86 -- You can use -- to mark the end of the flags, in case you need to use
87 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
88 -- though.
89 pastArgs "--" = True
90 pastArgs ('-':_) = False
91 pastArgs _ = True
92
93 dieProg :: String -> IO a
94 dieProg msg = do
95 p <- getProgName
96 hPutStrLn stderr (p ++ ": " ++ msg)
97 exitWith (ExitFailure 1)
98
99 -- usage :: String
100 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
101