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