1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
2 #if __GLASGOW_HASKELL__ < 603
7 -----------------------------------------------------------------------------
9 -- (c) The University of Glasgow, 2004
11 -- runghc program, for invoking from a #! line in a script. For example:
14 -- #!/usr/bin/env /usr/bin/runghc
15 -- > main = putStrLn "hello!"
17 -- runghc accepts one flag:
19 -- -f <path> specify the path
21 -- -----------------------------------------------------------------------------
23 module Main (main) where
27 import Control.Exception
33 import System.Directory
34 import System.Environment
36 import System.FilePath
39 #if defined(mingw32_HOST_OS)
42 import Foreign.C.String
48 case parseRunGhcFlags args of
49 (Help, _) -> printUsage
50 (ShowVersion, _) -> printVersion
51 (RunGhcFlags (Just ghc), args') -> doIt ghc args'
52 (RunGhcFlags Nothing, args') -> do
55 Nothing -> dieProg ("cannot find ghc")
57 let ghc = takeDirectory (normalise path) </> "ghc"
60 data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
61 | Help -- Print help text
62 | ShowVersion -- Print version info
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
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)
88 putStrLn ("runghc " ++ showVersion version)
92 putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
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"
99 doIt :: String -> [String] -> IO ()
101 let (ghc_args, rest) = getGhcArgs args
104 -- behave like typical perl, python, ruby interpreters:
106 tmpdir <- getTemporaryDirectory
108 (openTempFile tmpdir "runghcXXXX.hs")
109 (\(filename,h) -> do hClose h; removeFile filename)
110 $ \(filename,h) -> do
111 getContents >>= hPutStr 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.
118 -- If the file doesn't exist then GHC is going to look for
119 -- filename.hs and filename.lhs, and use the appropriate
121 exists <- doesFileExist filename
122 let xflag = if exists && (takeExtension filename /= ".lhs")
125 c1 = ":set prog " ++ show filename
126 c2 = ":main " ++ show prog_args
127 res <- rawSystem ghc (["-ignore-dot-ghci"] ++
130 [ "-e", c1, "-e", c2, filename])
133 getGhcArgs :: [String] -> ([String], [String])
135 = let (ghcArgs, otherArgs) = case break pastArgs args of
136 (xs, "--":ys) -> (xs, ys)
138 in (map unescape ghcArgs, otherArgs)
139 where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
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,
147 pastArgs ('-':_) = False
150 dieProg :: String -> IO a
153 hPutStrLn stderr (p ++ ": " ++ msg)
154 exitWith (ExitFailure 1)
157 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
159 getExecPath :: IO (Maybe String)
160 #if defined(mingw32_HOST_OS)
162 allocaArray len $ \buf -> do
163 ret <- getModuleFileName nullPtr buf len
164 if ret == 0 then return Nothing
165 else liftM Just $ peekCString buf
166 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
168 foreign import stdcall unsafe "GetModuleFileNameA"
169 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
171 getExecPath = return Nothing