summaryrefslogtreecommitdiff
path: root/utils/runghc/Main.hs
blob: dec53eefb0acacbcbf29651ce4ddc8e661668a66 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
{-# LANGUAGE CPP #-}
#include "ghcconfig.h"
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2004
--
-- runghc program, for invoking from a #! line in a script.  For example:
--
--   script.lhs:
--      #!/usr/bin/env runghc
--      > main = putStrLn "hello!"
--
-- runghc accepts one flag:
--
--      -f <path>    specify the path
--
-- -----------------------------------------------------------------------------

module Main (main) where

import Control.Exception
import Data.Semigroup as Semi
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO

#if defined(mingw32_HOST_OS)
import System.Process (rawSystem)
import Foreign
import Foreign.C.String
#else
import System.Posix.Process (executeFile)
#endif

#if defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# else
#  error Unknown mingw32 arch
# endif
#endif

main :: IO ()
main = do
    args <- getArgs
    case parseRunGhcFlags args of
        (Help, _) -> printUsage
        (ShowVersion, _) -> printVersion
        (RunGhcFlags (Just ghc), args') -> uncurry (doIt ghc) $ getGhcArgs args'
        (RunGhcFlags Nothing, args') -> do
            mbPath <- getExecPath
            case mbPath of
                Nothing  -> dieProg ("cannot find ghc")
                Just path -> do
                    ghc <- findGhc path
                    uncurry (doIt ghc) $ getGhcArgs args'

-- In some cases, runghc isn't given a path to ghc explicitly. This can occur
-- if $1_$2_SHELL_WRAPPER = NO (which is always the case on Windows). In such
-- a scenario, we must guess where ghc lives. Given a path where ghc might
-- live, we check for the existence of ghc. If we can't find it, we assume that
-- we're building ghc from source, in which case we fall back on ghc-stage2.
-- (See Trac #1185.)
findGhc :: FilePath -> IO FilePath
findGhc path = do
    let ghcDir = takeDirectory (normalise path)
        ghc    = ghcDir </> "ghc" <.> exeExtension
    ghcExists <- doesFileExist ghc
    return $ if ghcExists
             then ghc
             else ghcDir </> "ghc-stage2" <.> exeExtension

data RunGhcFlags = RunGhcFlags (Maybe FilePath) -- GHC location
                 | Help -- Print help text
                 | ShowVersion -- Print version info

instance Semi.Semigroup RunGhcFlags where
    Help <> _ = Help
    _ <> Help = Help
    ShowVersion <> _ = ShowVersion
    _ <> ShowVersion = ShowVersion
    RunGhcFlags _ <> right@(RunGhcFlags (Just _)) = right
    left@(RunGhcFlags _) <> RunGhcFlags Nothing = left

instance Monoid RunGhcFlags where
    mempty = RunGhcFlags Nothing
    mappend = (<>)

parseRunGhcFlags :: [String] -> (RunGhcFlags, [String])
parseRunGhcFlags = f mempty
    where f flags ("-f" : ghc : args)
              = f (flags `mappend` RunGhcFlags (Just ghc)) args
          f flags (('-' : 'f' : ghc) : args)
              = f (flags `mappend` RunGhcFlags (Just ghc)) args
          f flags ("--help" : args) = f (flags `mappend` Help) args
          f flags ("--version" : args) = f (flags `mappend` ShowVersion) args
          -- If you need the first GHC flag to be a -f flag then
          -- you can pass -- first
          f flags ("--" : args) = (flags, args)
          f flags         args  = (flags, args)

printVersion :: IO ()
printVersion = do
    putStrLn ("runghc " ++ VERSION)

printUsage :: IO ()
printUsage = do
    putStrLn "Usage: runghc [runghc flags] [GHC flags] module [program args]"
    putStrLn ""
    putStrLn "The runghc flags are"
    putStrLn "    -f /path/to/ghc       Tell runghc where GHC is"
    putStrLn "    --ghc-arg=<arg>       Pass an option or argument to GHC"
    putStrLn "    --help                Print this usage information"
    putStrLn "    --version             Print version number"

doIt :: String -- ^ path to GHC
     -> [String] -- ^ GHC args
     -> [String] -- ^ rest of the args
     -> IO ()
doIt ghc ghc_args rest = do
    case rest of
        [] -> do
           -- behave like typical perl, python, ruby interpreters:
           -- read from stdin
           tmpdir <- getTemporaryDirectory
           bracket
             (openTempFile tmpdir "runghcXXXX.hs")
             (\(filename,h) -> do hClose h; removeFile filename)
             $ \(filename,h) -> do
                 getContents >>= hPutStr h
                 hClose h
                 doIt ghc ghc_args [filename]
        filename : prog_args -> do
            -- If the file exists, and is not a .lhs file, then we
            -- want to treat it as a .hs file.
            --
            -- If the file doesn't exist then GHC is going to look for
            -- filename.hs and filename.lhs, and use the appropriate
            -- type.
            exists <- doesFileExist filename
            let xflag = if exists && (takeExtension filename /= ".lhs")
                        then ["-x", "hs"]
                        else []
                c1 = ":set prog " ++ show filename
                c2 = ":main " ++ show prog_args

            let cmd = ghc
                args = ["-ignore-dot-ghci"] ++
                       xflag ++
                       ghc_args ++
                       [ "-e", c1, "-e", c2, filename]


#if defined(mingw32_HOST_OS)
            rawSystem cmd args >>= exitWith
#else
            -- Passing False to avoid searching the PATH, since the cmd should
            -- always be an absolute path to the ghc executable.
            executeFile cmd False args Nothing
#endif

getGhcArgs :: [String] -> ([String], [String])
getGhcArgs args
 = let (ghcArgs, otherArgs) = case break pastArgs args of
                              (xs, "--":ys) -> (xs, ys)
                              (xs, ys)      -> (xs, ys)
   in (map unescape ghcArgs, otherArgs)
    where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) =
                case arg of
                    -- Bug #8601: allow --ghc-arg=--ghc-arg= as a prefix as well for backwards compatibility
                    ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg') -> arg'
                    _ -> arg
          unescape arg = arg

pastArgs :: String -> Bool
-- You can use -- to mark the end of the flags, in case you need to use
-- a file called -foo.hs for some reason. You almost certainly shouldn't,
-- though.
pastArgs "--" = True
pastArgs ('-':_) = False
pastArgs _       = True

dieProg :: String -> IO a
dieProg msg = do
    p <- getProgName
    hPutStrLn stderr (p ++ ": " ++ msg)
    exitWith (ExitFailure 1)

-- usage :: String
-- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."

getExecPath :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
  where
    try_size size = allocaArray (fromIntegral size) $ \buf -> do
        ret <- c_GetModuleFileName nullPtr buf size
        case ret of
          0 -> return Nothing
          _ | ret < size -> fmap Just $ peekCWString buf
            | otherwise  -> try_size (size * 2)

foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecPath = return Nothing
#endif