Fix warnings in CgTicky
[ghc-hetmet.git] / utils / runghc / runghc.hs
1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
2 #if __GLASGOW_HASKELL__ < 603
3 #include "config.h"
4 #else
5 #include "ghcconfig.h"
6 #endif
7 -----------------------------------------------------------------------------
8 --
9 -- (c) The University of Glasgow, 2004
10 --
11 -- runghc program, for invoking from a #! line in a script.  For example:
12 --
13 --   script.lhs:
14 --      #!/usr/bin/env /usr/bin/runghc
15 --      > main = putStrLn "hello!"
16 --
17 -- runghc accepts one flag:
18 --
19 --      -f <path>    specify the path
20 --
21 -- -----------------------------------------------------------------------------
22
23 module Main (main) where
24
25 import Control.Exception
26 import Data.Char
27 import Data.List
28 import Data.Monoid
29 import System.Cmd
30 import System.Directory
31 import System.Environment
32 import System.Exit
33 import System.FilePath
34 import System.IO
35
36 #if defined(mingw32_HOST_OS)
37 import Control.Monad
38 import Foreign
39 import Foreign.C.String
40 #endif
41
42 main :: IO ()
43 main = do
44     args <- getArgs
45     case parseRunGhcFlags args of
46         (Help, _) -> printUsage
47         (RunGhcFlags (Just ghc), args') -> doIt ghc args'
48         (RunGhcFlags Nothing, args') -> do
49             mbPath <- getExecPath
50             case mbPath of
51                 Nothing  -> dieProg ("cannot find ghc")
52                 Just path ->
53                     let ghc = takeDirectory (normalise path) </> "ghc"
54                     in doIt ghc args'
55
56 data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
57                  | Help -- Print help text
58
59 instance Monoid RunGhcFlags where
60     mempty = RunGhcFlags Nothing
61     Help `mappend` _ = Help
62     _ `mappend` Help = Help
63     RunGhcFlags _ `mappend` right@(RunGhcFlags (Just _)) = right
64     left@(RunGhcFlags _) `mappend` RunGhcFlags Nothing = left
65
66 parseRunGhcFlags :: [String] -> (RunGhcFlags, [String])
67 parseRunGhcFlags = f mempty
68     where f flags ("-f" : ghc : args)
69               = f (flags `mappend` RunGhcFlags (Just ghc)) args
70           f flags (('-' : 'f' : ghc) : args)
71               = f (flags `mappend` RunGhcFlags (Just ghc)) args
72           f flags ("--help" : args) = f (flags `mappend` Help) args
73           -- If you need the first GHC flag to be a -f flag then
74           -- you can pass -- first
75           f flags ("--" : args) = (flags, args)
76           f flags         args  = (flags, args)
77
78 printUsage :: IO ()
79 printUsage = do
80     putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
81     putStrLn ""
82     putStrLn "The runghc flags are"
83     putStrLn "    -f /path/to/ghc       Tell runghc where GHC is"
84     putStrLn "    --help                Print this usage information"
85
86 doIt :: String -> [String] -> IO ()
87 doIt ghc args = do
88     let (ghc_args, rest) = getGhcArgs args
89     case rest of
90         [] -> do
91            -- behave like typical perl, python, ruby interpreters:
92            -- read from stdin
93            tmpdir <- getTemporaryDirectory
94            bracket
95              (openTempFile tmpdir "runghcXXXX.hs")
96              (\(filename,h) -> do hClose h; removeFile filename)
97              $ \(filename,h) -> do
98                  getContents >>= hPutStr h
99                  hClose h
100                  doIt ghc (ghc_args ++ [filename])
101         filename : prog_args -> do
102             -- If the file exists, and is not a .lhs file, then we
103             -- want to treat it as a .hs file.
104             --
105             -- If the file doesn't exist then GHC is going to look for
106             -- filename.hs and filename.lhs, and use the appropriate
107             -- type.
108             exists <- doesFileExist filename
109             let xflag = if exists && (takeExtension filename /= ".lhs")
110                         then ["-x", "hs"]
111                         else []
112                 c1 = ":set prog " ++ show filename
113                 c2 = ":main " ++ show prog_args
114             res <- rawSystem ghc (["-ignore-dot-ghci"] ++
115                                   xflag ++
116                                   ghc_args ++
117                                   [ "-e", c1, "-e", c2, filename])
118             exitWith res
119
120 getGhcArgs :: [String] -> ([String], [String])
121 getGhcArgs args
122  = let (ghcArgs, otherArgs) = case break pastArgs args of
123                               (xs, "--":ys) -> (xs, ys)
124                               (xs, ys)      -> (xs, ys)
125    in (map unescape ghcArgs, otherArgs)
126     where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
127           unescape arg = arg
128
129 pastArgs :: String -> Bool
130 -- You can use -- to mark the end of the flags, in case you need to use
131 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
132 -- though.
133 pastArgs "--" = True
134 pastArgs ('-':_) = False
135 pastArgs _       = True
136
137 dieProg :: String -> IO a
138 dieProg msg = do
139     p <- getProgName
140     hPutStrLn stderr (p ++ ": " ++ msg)
141     exitWith (ExitFailure 1)
142
143 -- usage :: String
144 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
145
146 getExecPath :: IO (Maybe String)
147 #if defined(mingw32_HOST_OS)
148 getExecPath =
149      allocaArray len $ \buf -> do
150          ret <- getModuleFileName nullPtr buf len
151          if ret == 0 then return Nothing
152                      else liftM Just $ peekCString buf
153     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
154
155 foreign import stdcall unsafe "GetModuleFileNameA"
156     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
157 #else
158 getExecPath = return Nothing
159 #endif
160