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