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