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 c1 = ":set prog " ++ show filename
  80                 c2 = ":main " ++ show prog_args
  81             res <- rawSystem ghc (["-ignore-dot-ghci"] ++ ghc_args ++
  82                                   [ "-e", c1, "-e", c2, filename])
  83             exitWith res
  84
  85 getGhcArgs :: [String] -> ([String], [String])
  86 getGhcArgs args
  87  = let (ghcArgs, otherArgs) = case break pastArgs args of
  88                               (xs, "--":ys) -> (xs, ys)
  89                               (xs, ys)      -> (xs, ys)
  90    in (map unescape ghcArgs, otherArgs)
  91     where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
  92           unescape arg = arg
  93
  94 pastArgs :: String -> Bool
  95 -- You can use -- to mark the end of the flags, in case you need to use
  96 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
  97 -- though.
  98 pastArgs "--" = True
  99 pastArgs ('-':_) = False
 100 pastArgs _       = True
 101
 102 dieProg :: String -> IO a
 103 dieProg msg = do
 104     p <- getProgName
 105     hPutStrLn stderr (p ++ ": " ++ msg)
 106     exitWith (ExitFailure 1)
 107
 108 -- usage :: String
 109 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
 110
 111 getExecPath :: IO (Maybe String)
 112 #if defined(mingw32_HOST_OS)
 113 getExecPath =
 114      allocaArray len $ \buf -> do
 115          ret <- getModuleFileName nullPtr buf len
 116          if ret == 0 then return Nothing
 117                      else liftM Just $ peekCString buf
 118     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
 119
 120 foreign import stdcall unsafe "GetModuleFileNameA"
 121     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 122 #else
 123 getExecPath = return Nothing
 124 #endif
 125