utils/runghc/runghc.hs

   1 {-# OPTIONS -cpp -fffi #-}
   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/runghc
  15 --      > main = putStrLn "hello!"
  16 --
  17 -- runghc accepts one flag:
  18 --
  19 --      -f <path>    specify the path
  20 --
  21 -- -----------------------------------------------------------------------------
  22
  23 module Main where
  24
  25 import System.Environment
  26 import System.IO
  27 import Data.List
  28 import System.Exit
  29 import Data.Char
  30
  31 import Compat.RawSystem         ( rawSystem )
  32 import Compat.Directory         ( findExecutable )
  33
  34 main = do
  35   args <- getArgs
  36   case args of
  37     ('-':'f' : ghc) : args -> do
  38         doIt (dropWhile isSpace ghc) args
  39     args -> do
  40         mb_ghc <- findExecutable "ghc"
  41         case mb_ghc of
  42           Nothing  -> dieProg ("cannot find ghc")
  43           Just ghc -> doIt ghc args
  44
  45 doIt ghc args = do
  46   let
  47     (ghc_args, rest) = break notArg args
  48   --
  49   case rest of
  50      [] -> dieProg "syntax: runghc [-f GHCPATH] [GHC-ARGS] FILE ARG..."
  51      filename : prog_args -> do
  52           res <- rawSystem ghc (
  53                         "-ignore-dot-ghci" : ghc_args ++
  54                         [ "-e","System.Environment.withProgName "++show filename++" (System.Environment.withArgs ["
  55                           ++ concat (intersperse "," (map show prog_args))
  56                           ++ "] Main.main)", filename])
  57           exitWith res
  58
  59 notArg ('-':_) = False
  60 notArg _       = True
  61
  62 dieProg :: String -> IO a
  63 dieProg msg = do
  64   p <- getProgName
  65   hPutStrLn stderr (p ++ ": " ++ msg)
  66   exitWith (ExitFailure 1)