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