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