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