Remove LANGUAGE pragrams implied by Haskell2010
[ghc.git] / utils / runghc / runghc.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 /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.Directory
24 import System.Environment
25 import System.Exit
26 import System.FilePath
27 import System.IO
28 import System.Process
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') -> uncurry (doIt ghc) $ getGhcArgs 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 uncurry (doIt ghc) $ getGhcArgs 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 -- ^ path to GHC
100 -> [String] -- ^ GHC args
101 -> [String] -- ^ rest of the args
102 -> IO ()
103 doIt ghc ghc_args rest = do
104 case rest of
105 [] -> do
106 -- behave like typical perl, python, ruby interpreters:
107 -- read from stdin
108 tmpdir <- getTemporaryDirectory
109 bracket
110 (openTempFile tmpdir "runghcXXXX.hs")
111 (\(filename,h) -> do hClose h; removeFile filename)
112 $ \(filename,h) -> do
113 getContents >>= hPutStr h
114 hClose h
115 doIt ghc ghc_args [filename]
116 filename : prog_args -> do
117 -- If the file exists, and is not a .lhs file, then we
118 -- want to treat it as a .hs file.
119 --
120 -- If the file doesn't exist then GHC is going to look for
121 -- filename.hs and filename.lhs, and use the appropriate
122 -- type.
123 exists <- doesFileExist filename
124 let xflag = if exists && (takeExtension filename /= ".lhs")
125 then ["-x", "hs"]
126 else []
127 c1 = ":set prog " ++ show filename
128 c2 = ":main " ++ show prog_args
129 res <- rawSystem ghc (["-ignore-dot-ghci"] ++
130 xflag ++
131 ghc_args ++
132 [ "-e", c1, "-e", c2, filename])
133 exitWith res
134
135 getGhcArgs :: [String] -> ([String], [String])
136 getGhcArgs args
137 = let (ghcArgs, otherArgs) = case break pastArgs args of
138 (xs, "--":ys) -> (xs, ys)
139 (xs, ys) -> (xs, ys)
140 in (map unescape ghcArgs, otherArgs)
141 where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) =
142 case arg of
143 -- Bug #8601: allow --ghc-arg=--ghc-arg= as a prefix as well for backwards compatibility
144 ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg') -> arg'
145 _ -> arg
146 unescape arg = arg
147
148 pastArgs :: String -> Bool
149 -- You can use -- to mark the end of the flags, in case you need to use
150 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
151 -- though.
152 pastArgs "--" = True
153 pastArgs ('-':_) = False
154 pastArgs _ = True
155
156 dieProg :: String -> IO a
157 dieProg msg = do
158 p <- getProgName
159 hPutStrLn stderr (p ++ ": " ++ msg)
160 exitWith (ExitFailure 1)
161
162 -- usage :: String
163 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
164
165 getExecPath :: IO (Maybe String)
166 #if defined(mingw32_HOST_OS)
167 getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
168 where
169 try_size size = allocaArray (fromIntegral size) $ \buf -> do
170 ret <- c_GetModuleFileName nullPtr buf size
171 case ret of
172 0 -> return Nothing
173 _ | ret < size -> fmap Just $ peekCWString buf
174 | otherwise -> try_size (size * 2)
175
176 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
177 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
178 #else
179 getExecPath = return Nothing
180 #endif
181