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
25 import Control.Exception
29 import System.Directory
30 import System.Environment
32 import System.FilePath
35 #if defined(mingw32_HOST_OS)
38 import Foreign.C.String
44 case getGhcLoc args of
45 (Just ghc, args') -> doIt ghc args'
46 (Nothing, args') -> do
49 Nothing -> dieProg ("cannot find ghc")
51 let ghc = takeDirectory (normalise path) </> "ghc"
54 getGhcLoc :: [String] -> (Maybe FilePath, [String])
55 getGhcLoc args = case args of
56 "-f" : ghc : args' -> f ghc args'
57 ('-' : 'f' : ghc) : args' -> f ghc args'
58 -- If you need the first GHC flag to be a -f flag then
59 -- you can pass -- first
60 "--" : args' -> (Nothing, args')
62 where f ghc args' = -- If there is another -f flag later on then
63 -- that overrules the one that we've already
65 case getGhcLoc args' of
66 (Nothing, _) -> (Just ghc, args')
69 doIt :: String -> [String] -> IO ()
71 let (ghc_args, rest) = getGhcArgs args
74 -- behave like typical perl, python, ruby interpreters:
76 tmpdir <- getTemporaryDirectory
78 (openTempFile tmpdir "runghcXXXX.hs")
79 (\(filename,_) -> removeFile filename)
81 getContents >>= hPutStr h
83 doIt ghc (ghc_args ++ [filename])
84 filename : prog_args -> do
85 -- If the file exists, and is not a .lhs file, then we
86 -- want to treat it as a .hs file.
88 -- If the file doesn't exist then GHC is going to look for
89 -- filename.hs and filename.lhs, and use the appropriate
91 exists <- doesFileExist filename
92 let xflag = if exists && (takeExtension filename /= ".lhs")
95 c1 = ":set prog " ++ show filename
96 c2 = ":main " ++ show prog_args
97 res <- rawSystem ghc (["-ignore-dot-ghci"] ++
100 [ "-e", c1, "-e", c2, filename])
103 getGhcArgs :: [String] -> ([String], [String])
105 = let (ghcArgs, otherArgs) = case break pastArgs args of
106 (xs, "--":ys) -> (xs, ys)
108 in (map unescape ghcArgs, otherArgs)
109 where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
112 pastArgs :: String -> Bool
113 -- You can use -- to mark the end of the flags, in case you need to use
114 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
117 pastArgs ('-':_) = False
120 dieProg :: String -> IO a
123 hPutStrLn stderr (p ++ ": " ++ msg)
124 exitWith (ExitFailure 1)
127 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
129 getExecPath :: IO (Maybe String)
130 #if defined(mingw32_HOST_OS)
132 allocaArray len $ \buf -> do
133 ret <- getModuleFileName nullPtr buf len
134 if ret == 0 then return Nothing
135 else liftM Just $ peekCString buf
136 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
138 foreign import stdcall unsafe "GetModuleFileNameA"
139 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
141 getExecPath = return Nothing