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             -- If the file exists, and is not a .lhs file, then we
  86             -- want to treat it as a .hs file.
  87             --
  88             -- If the file doesn't exist then GHC is going to look for
  89             -- filename.hs and filename.lhs, and use the appropriate
  90             -- type.
  91             exists <- doesFileExist filename
  92             let xflag = if exists && (takeExtension filename /= ".lhs")
  93                         then ["-x", "hs"]
  94                         else []
  95                 c1 = ":set prog " ++ show filename
  96                 c2 = ":main " ++ show prog_args
  97             res <- rawSystem ghc (["-ignore-dot-ghci"] ++
  98                                   xflag ++
  99                                   ghc_args ++
 100                                   [ "-e", c1, "-e", c2, filename])
 101             exitWith res
 102
 103 getGhcArgs :: [String] -> ([String], [String])
 104 getGhcArgs args
 105  = let (ghcArgs, otherArgs) = case break pastArgs args of
 106                               (xs, "--":ys) -> (xs, ys)
 107                               (xs, ys)      -> (xs, ys)
 108    in (map unescape ghcArgs, otherArgs)
 109     where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
 110           unescape arg = arg
 111
 112 pastArgs :: String -> Bool
 113 -- You can use -- to mark the end of the flags, in case you need to use
 114 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
 115 -- though.
 116 pastArgs "--" = True
 117 pastArgs ('-':_) = False
 118 pastArgs _       = True
 119
 120 dieProg :: String -> IO a
 121 dieProg msg = do
 122     p <- getProgName
 123     hPutStrLn stderr (p ++ ": " ++ msg)
 124     exitWith (ExitFailure 1)
 125
 126 -- usage :: String
 127 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
 128
 129 getExecPath :: IO (Maybe String)
 130 #if defined(mingw32_HOST_OS)
 131 getExecPath =
 132      allocaArray len $ \buf -> do
 133          ret <- getModuleFileName nullPtr buf len
 134          if ret == 0 then return Nothing
 135                      else liftM Just $ peekCString buf
 136     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
 137
 138 foreign import stdcall unsafe "GetModuleFileNameA"
 139     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 140 #else
 141 getExecPath = return Nothing
 142 #endif
 143