utils/runghc/runghc.hs

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