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 System.Cmd
  29 import System.Directory
  30 import System.Environment
  31 import System.Exit
  32 import System.FilePath
  33 import System.IO
  34
  35 #if defined(mingw32_HOST_OS)
  36 import Control.Monad
  37 import Foreign
  38 import Foreign.C.String
  39 #endif
  40
  41 main :: IO ()
  42 main = do
  43     args <- getArgs
  44     case getGhcLoc args of
  45         (Just ghc, args') -> doIt ghc args'
  46         (Nothing, args') -> do
  47             mbPath <- getExecPath
  48             case mbPath of
  49                 Nothing  -> dieProg ("cannot find ghc")
  50                 Just path ->
  51                     let ghc = takeDirectory (normalise path) </> "ghc"
  52                     in doIt ghc args'
  53
  54 getGhcLoc :: [String] -> (Maybe FilePath, [String])
  55 getGhcLoc args = case args of
  56                  "-f" : ghc : args' -> f ghc args'
  57                  ('-' : 'f' : ghc) : args' -> f ghc args'
  58                  -- If you need the first GHC flag to be a -f flag then
  59                  -- you can pass -- first
  60                  "--" : args' -> (Nothing, args')
  61                  _            -> (Nothing, args)
  62     where f ghc args' = -- If there is another -f flag later on then
  63                         -- that overrules the one that we've already
  64                         -- found
  65                         case getGhcLoc args' of
  66                         (Nothing, _) -> (Just ghc, args')
  67                         success -> success
  68
  69 doIt :: String -> [String] -> IO ()
  70 doIt ghc args = do
  71     let (ghc_args, rest) = getGhcArgs args
  72     case rest of
  73         [] -> do
  74            -- behave like typical perl, python, ruby interpreters:
  75            -- read from stdin
  76            tmpdir <- getTemporaryDirectory
  77            bracket
  78              (openTempFile tmpdir "runghcXXXX.hs")
  79              (\(filename,_) -> removeFile filename)
  80              $ \(filename,h) -> do
  81                  getContents >>= hPutStr h
  82                  hClose h
  83                  doIt ghc (ghc_args ++ [filename])
  84         filename : prog_args -> do
  85             let xflag = if takeExtension filename == ".lhs"
  86                         then []
  87                         else ["-x", "hs"]
  88                 c1 = ":set prog " ++ show filename
  89                 c2 = ":main " ++ show prog_args
  90             res <- rawSystem ghc (["-ignore-dot-ghci"] ++
  91                                   xflag ++
  92                                   ghc_args ++
  93                                   [ "-e", c1, "-e", c2, filename])
  94             exitWith res
  95
  96 getGhcArgs :: [String] -> ([String], [String])
  97 getGhcArgs args
  98  = let (ghcArgs, otherArgs) = case break pastArgs args of
  99                               (xs, "--":ys) -> (xs, ys)
 100                               (xs, ys)      -> (xs, ys)
 101    in (map unescape ghcArgs, otherArgs)
 102     where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
 103           unescape arg = arg
 104
 105 pastArgs :: String -> Bool
 106 -- You can use -- to mark the end of the flags, in case you need to use
 107 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
 108 -- though.
 109 pastArgs "--" = True
 110 pastArgs ('-':_) = False
 111 pastArgs _       = True
 112
 113 dieProg :: String -> IO a
 114 dieProg msg = do
 115     p <- getProgName
 116     hPutStrLn stderr (p ++ ": " ++ msg)
 117     exitWith (ExitFailure 1)
 118
 119 -- usage :: String
 120 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
 121
 122 getExecPath :: IO (Maybe String)
 123 #if defined(mingw32_HOST_OS)
 124 getExecPath =
 125      allocaArray len $ \buf -> do
 126          ret <- getModuleFileName nullPtr buf len
 127          if ret == 0 then return Nothing
 128                      else liftM Just $ peekCString buf
 129     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
 130
 131 foreign import stdcall unsafe "GetModuleFileNameA"
 132     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 133 #else
 134 getExecPath = return Nothing
 135 #endif
 136