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