b5d4a4a9caaf8ac416c942c375d5b5ef4ad7c542
[ghc.git] / utils / runghc / Main.hs
1 {-# LANGUAGE CPP #-}
2 #include "ghcconfig.h"
3 -----------------------------------------------------------------------------
4 --
5 -- (c) The University of Glasgow, 2004
6 --
7 -- runghc program, for invoking from a #! line in a script. For example:
8 --
9 -- script.lhs:
10 -- #!/usr/bin/env runghc
11 -- > main = putStrLn "hello!"
12 --
13 -- runghc accepts one flag:
14 --
15 -- -f <path> specify the path
16 --
17 -- -----------------------------------------------------------------------------
18
19 module Main (main) where
20
21 import Control.Exception
22 import System.Directory
23 import System.Environment
24 import System.Exit
25 import System.FilePath
26 import System.IO
27
28 #if defined(mingw32_HOST_OS)
29 import System.Process (rawSystem)
30 import Foreign
31 import Foreign.C.String
32 #else
33 import System.Posix.Process (executeFile)
34 #endif
35
36 #if defined(mingw32_HOST_OS)
37 # if defined(i386_HOST_ARCH)
38 # define WINDOWS_CCONV stdcall
39 # elif defined(x86_64_HOST_ARCH)
40 # define WINDOWS_CCONV ccall
41 # else
42 # error Unknown mingw32 arch
43 # endif
44 #endif
45
46 main :: IO ()
47 main = do
48 args <- getArgs
49 case parseRunGhcFlags args of
50 (Help, _) -> printUsage
51 (ShowVersion, _) -> printVersion
52 (RunGhcFlags (Just ghc), args') -> uncurry (doIt ghc) $ getGhcArgs args'
53 (RunGhcFlags Nothing, args') -> do
54 mbPath <- getExecPath
55 case mbPath of
56 Nothing -> dieProg ("cannot find ghc")
57 Just path -> do
58 ghc <- findGhc path
59 uncurry (doIt ghc) $ getGhcArgs args'
60
61 -- In some cases, runghc isn't given a path to ghc explicitly. This can occur
62 -- if $1_$2_SHELL_WRAPPER = NO (which is always the case on Windows). In such
63 -- a scenario, we must guess where ghc lives. Given a path where ghc might
64 -- live, we check for the existence of ghc. If we can't find it, we assume that
65 -- we're building ghc from source, in which case we fall back on ghc-stage2.
66 -- (See Trac #1185.)
67 findGhc :: FilePath -> IO FilePath
68 findGhc path = do
69 let ghcDir = takeDirectory (normalise path)
70 ghc = ghcDir </> "ghc" <.> exeExtension
71 ghcExists <- doesFileExist ghc
72 return $ if ghcExists
73 then ghc
74 else ghcDir </> "ghc-stage2" <.> exeExtension
75
76 data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
77 | Help -- Print help text
78 | ShowVersion -- Print version info
79
80 instance Monoid RunGhcFlags where
81 mempty = RunGhcFlags Nothing
82 Help `mappend` _ = Help
83 _ `mappend` Help = Help
84 ShowVersion `mappend` _ = ShowVersion
85 _ `mappend` ShowVersion = ShowVersion
86 RunGhcFlags _ `mappend` right@(RunGhcFlags (Just _)) = right
87 left@(RunGhcFlags _) `mappend` RunGhcFlags Nothing = left
88
89 parseRunGhcFlags :: [String] -> (RunGhcFlags, [String])
90 parseRunGhcFlags = f mempty
91 where f flags ("-f" : ghc : args)
92 = f (flags `mappend` RunGhcFlags (Just ghc)) args
93 f flags (('-' : 'f' : ghc) : args)
94 = f (flags `mappend` RunGhcFlags (Just ghc)) args
95 f flags ("--help" : args) = f (flags `mappend` Help) args
96 f flags ("--version" : args) = f (flags `mappend` ShowVersion) args
97 -- If you need the first GHC flag to be a -f flag then
98 -- you can pass -- first
99 f flags ("--" : args) = (flags, args)
100 f flags args = (flags, args)
101
102 printVersion :: IO ()
103 printVersion = do
104 putStrLn ("runghc " ++ VERSION)
105
106 printUsage :: IO ()
107 printUsage = do
108 putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
109 putStrLn ""
110 putStrLn "The runghc flags are"
111 putStrLn " -f /path/to/ghc Tell runghc where GHC is"
112 putStrLn " --ghc-arg=<arg> Pass an option or argument to GHC"
113 putStrLn " --help Print this usage information"
114 putStrLn " --version Print version number"
115
116 doIt :: String -- ^ path to GHC
117 -> [String] -- ^ GHC args
118 -> [String] -- ^ rest of the args
119 -> IO ()
120 doIt ghc ghc_args rest = do
121 case rest of
122 [] -> do
123 -- behave like typical perl, python, ruby interpreters:
124 -- read from stdin
125 tmpdir <- getTemporaryDirectory
126 bracket
127 (openTempFile tmpdir "runghcXXXX.hs")
128 (\(filename,h) -> do hClose h; removeFile filename)
129 $ \(filename,h) -> do
130 getContents >>= hPutStr h
131 hClose h
132 doIt ghc ghc_args [filename]
133 filename : prog_args -> do
134 -- If the file exists, and is not a .lhs file, then we
135 -- want to treat it as a .hs file.
136 --
137 -- If the file doesn't exist then GHC is going to look for
138 -- filename.hs and filename.lhs, and use the appropriate
139 -- type.
140 exists <- doesFileExist filename
141 let xflag = if exists && (takeExtension filename /= ".lhs")
142 then ["-x", "hs"]
143 else []
144 c1 = ":set prog " ++ show filename
145 c2 = ":main " ++ show prog_args
146
147 let cmd = ghc
148 args = ["-ignore-dot-ghci"] ++
149 xflag ++
150 ghc_args ++
151 [ "-e", c1, "-e", c2, filename]
152
153
154 #if defined(mingw32_HOST_OS)
155 rawSystem cmd args >>= exitWith
156 #else
157 -- Passing False to avoid searching the PATH, since the cmd should
158 -- always be an absolute path to the ghc executable.
159 executeFile cmd False args Nothing
160 #endif
161
162 getGhcArgs :: [String] -> ([String], [String])
163 getGhcArgs args
164 = let (ghcArgs, otherArgs) = case break pastArgs args of
165 (xs, "--":ys) -> (xs, ys)
166 (xs, ys) -> (xs, ys)
167 in (map unescape ghcArgs, otherArgs)
168 where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) =
169 case arg of
170 -- Bug #8601: allow --ghc-arg=--ghc-arg= as a prefix as well for backwards compatibility
171 ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg') -> arg'
172 _ -> arg
173 unescape arg = arg
174
175 pastArgs :: String -> Bool
176 -- You can use -- to mark the end of the flags, in case you need to use
177 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
178 -- though.
179 pastArgs "--" = True
180 pastArgs ('-':_) = False
181 pastArgs _ = True
182
183 dieProg :: String -> IO a
184 dieProg msg = do
185 p <- getProgName
186 hPutStrLn stderr (p ++ ": " ++ msg)
187 exitWith (ExitFailure 1)
188
189 -- usage :: String
190 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
191
192 getExecPath :: IO (Maybe String)
193 #if defined(mingw32_HOST_OS)
194 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
195 where
196 try_size size = allocaArray (fromIntegral size) $ \buf -> do
197 ret <- c_GetModuleFileName nullPtr buf size
198 case ret of
199 0 -> return Nothing
200 _ | ret < size -> fmap Just $ peekCWString buf
201 | otherwise -> try_size (size * 2)
202
203 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
204 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
205 #else
206 getExecPath = return Nothing
207 #endif