Don't use stdcall on Win64: It isn't supported; ccall is used instead
[ghc.git] / utils / runghc / runghc.hs
1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
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 /usr/bin/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.Monoid
23 import System.Cmd
24 import System.Directory
25 import System.Environment
26 import System.Exit
27 import System.FilePath
28 import System.IO
29
30 #if defined(mingw32_HOST_OS)
31 import Foreign
32 import Foreign.C.String
33 #endif
34
35 #if defined(i386_HOST_ARCH)
36 # define WINDOWS_CCONV stdcall
37 #elif defined(x86_64_HOST_ARCH)
38 # define WINDOWS_CCONV ccall
39 #else
40 # error Unknown mingw32 arch
41 #endif
42
43 main :: IO ()
44 main = do
45 args <- getArgs
46 case parseRunGhcFlags args of
47 (Help, _) -> printUsage
48 (ShowVersion, _) -> printVersion
49 (RunGhcFlags (Just ghc), args') -> doIt ghc args'
50 (RunGhcFlags Nothing, args') -> do
51 mbPath <- getExecPath
52 case mbPath of
53 Nothing -> dieProg ("cannot find ghc")
54 Just path ->
55 let ghc = takeDirectory (normalise path) </> "ghc"
56 in doIt ghc args'
57
58 data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
59 | Help -- Print help text
60 | ShowVersion -- Print version info
61
62 instance Monoid RunGhcFlags where
63 mempty = RunGhcFlags Nothing
64 Help `mappend` _ = Help
65 _ `mappend` Help = Help
66 ShowVersion `mappend` _ = ShowVersion
67 _ `mappend` ShowVersion = ShowVersion
68 RunGhcFlags _ `mappend` right@(RunGhcFlags (Just _)) = right
69 left@(RunGhcFlags _) `mappend` RunGhcFlags Nothing = left
70
71 parseRunGhcFlags :: [String] -> (RunGhcFlags, [String])
72 parseRunGhcFlags = f mempty
73 where f flags ("-f" : ghc : args)
74 = f (flags `mappend` RunGhcFlags (Just ghc)) args
75 f flags (('-' : 'f' : ghc) : args)
76 = f (flags `mappend` RunGhcFlags (Just ghc)) args
77 f flags ("--help" : args) = f (flags `mappend` Help) args
78 f flags ("--version" : args) = f (flags `mappend` ShowVersion) args
79 -- If you need the first GHC flag to be a -f flag then
80 -- you can pass -- first
81 f flags ("--" : args) = (flags, args)
82 f flags args = (flags, args)
83
84 printVersion :: IO ()
85 printVersion = do
86 putStrLn ("runghc " ++ VERSION)
87
88 printUsage :: IO ()
89 printUsage = do
90 putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
91 putStrLn ""
92 putStrLn "The runghc flags are"
93 putStrLn " -f /path/to/ghc Tell runghc where GHC is"
94 putStrLn " --help Print this usage information"
95 putStrLn " --version Print version number"
96
97 doIt :: String -> [String] -> IO ()
98 doIt ghc args = do
99 let (ghc_args, rest) = getGhcArgs args
100 case rest of
101 [] -> do
102 -- behave like typical perl, python, ruby interpreters:
103 -- read from stdin
104 tmpdir <- getTemporaryDirectory
105 bracket
106 (openTempFile tmpdir "runghcXXXX.hs")
107 (\(filename,h) -> do hClose h; removeFile filename)
108 $ \(filename,h) -> do
109 getContents >>= hPutStr h
110 hClose h
111 doIt ghc (ghc_args ++ [filename])
112 filename : prog_args -> do
113 -- If the file exists, and is not a .lhs file, then we
114 -- want to treat it as a .hs file.
115 --
116 -- If the file doesn't exist then GHC is going to look for
117 -- filename.hs and filename.lhs, and use the appropriate
118 -- type.
119 exists <- doesFileExist filename
120 let xflag = if exists && (takeExtension filename /= ".lhs")
121 then ["-x", "hs"]
122 else []
123 c1 = ":set prog " ++ show filename
124 c2 = ":main " ++ show prog_args
125 res <- rawSystem ghc (["-ignore-dot-ghci"] ++
126 xflag ++
127 ghc_args ++
128 [ "-e", c1, "-e", c2, filename])
129 exitWith res
130
131 getGhcArgs :: [String] -> ([String], [String])
132 getGhcArgs args
133 = let (ghcArgs, otherArgs) = case break pastArgs args of
134 (xs, "--":ys) -> (xs, ys)
135 (xs, ys) -> (xs, ys)
136 in (map unescape ghcArgs, otherArgs)
137 where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
138 unescape arg = arg
139
140 pastArgs :: String -> Bool
141 -- You can use -- to mark the end of the flags, in case you need to use
142 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
143 -- though.
144 pastArgs "--" = True
145 pastArgs ('-':_) = False
146 pastArgs _ = True
147
148 dieProg :: String -> IO a
149 dieProg msg = do
150 p <- getProgName
151 hPutStrLn stderr (p ++ ": " ++ msg)
152 exitWith (ExitFailure 1)
153
154 -- usage :: String
155 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
156
157 getExecPath :: IO (Maybe String)
158 #if defined(mingw32_HOST_OS)
159 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
160 where
161 try_size size = allocaArray (fromIntegral size) $ \buf -> do
162 ret <- c_GetModuleFileName nullPtr buf size
163 case ret of
164 0 -> return Nothing
165 _ | ret < size -> fmap Just $ peekCWString buf
166 | otherwise -> try_size (size * 2)
167
168 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
169 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
170 #else
171 getExecPath = return Nothing
172 #endif
173