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