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 (main) where
  24
  25 import System.Environment
  26 import System.IO
  27 import Data.List
  28 import System.Exit
  29 import Data.Char
  30 import System.Directory ( removeFile )
  31 import Control.Exception  ( bracket )
  32 import System.Directory ( findExecutable, getTemporaryDirectory )
  33
  34 #ifdef USING_COMPAT
  35 import Compat.RawSystem ( rawSystem )
  36 #else
  37 import System.Cmd       ( rawSystem )
  38 #endif
  39
  40 main :: IO ()
  41 main = do
  42     args <- getArgs
  43     case getGhcLoc args of
  44         (Just ghc, args') -> doIt ghc args'
  45         (Nothing, args') -> do
  46             mb_ghc <- findExecutable "ghc"
  47             case mb_ghc of
  48                 Nothing  -> dieProg ("cannot find ghc")
  49                 Just ghc -> doIt ghc args'
  50
  51 getGhcLoc :: [String] -> (Maybe FilePath, [String])
  52 getGhcLoc ("-f" : ghc : args) = (Just ghc, args)
  53 getGhcLoc (('-' : 'f' : ghc) : args) = (Just ghc, args)
  54 -- If you need the first GHC flag to be a -f flag then you can pass --
  55 -- first
  56 getGhcLoc ("--" : args) = (Nothing, args)
  57 getGhcLoc args = (Nothing, args)
  58
  59 doIt :: String -> [String] -> IO ()
  60 doIt ghc args = do
  61     let (ghc_args, rest) = getGhcArgs args
  62     case rest of
  63         [] -> do
  64            -- behave like typical perl, python, ruby interpreters:
  65            -- read from stdin
  66            tmpdir <- getTemporaryDirectory
  67            bracket
  68              (openTempFile tmpdir "runghcXXXX.hs")
  69              (\(filename,_) -> removeFile filename)
  70              $ \(filename,h) -> do
  71                  getContents >>= hPutStr h
  72                  hClose h
  73                  doIt ghc (ghc_args ++ [filename])
  74         filename : prog_args -> do
  75             let c1 = ":set prog " ++ show filename
  76                 c2 = ":main " ++ show prog_args
  77             res <- rawSystem ghc (["-ignore-dot-ghci"] ++ ghc_args ++
  78                                   [ "-e", c1, "-e", c2, filename])
  79             exitWith res
  80
  81 getGhcArgs :: [String] -> ([String], [String])
  82 getGhcArgs args
  83  = let (ghcArgs, otherArgs) = case break pastArgs args of
  84                               (xs, "--":ys) -> (xs, ys)
  85                               (xs, ys)      -> (xs, ys)
  86    in (map unescape ghcArgs, otherArgs)
  87     where unescape ('-':'-':'g':'h':'c':'-':'a':'r':'g':'=':arg) = arg
  88           unescape arg = arg
  89
  90 pastArgs :: String -> Bool
  91 -- You can use -- to mark the end of the flags, in case you need to use
  92 -- a file called -foo.hs for some reason. You almost certainly shouldn't,
  93 -- though.
  94 pastArgs "--" = True
  95 pastArgs ('-':_) = False
  96 pastArgs _       = True
  97
  98 dieProg :: String -> IO a
  99 dieProg msg = do
 100     p <- getProgName
 101     hPutStrLn stderr (p ++ ": " ++ msg)
 102     exitWith (ExitFailure 1)
 103
 104 -- usage :: String
 105 -- usage = "syntax: runghc [-f GHC-PATH | --] [GHC-ARGS] [--] FILE ARG..."
 106