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