eddie-0.5.1: eddie.hs

#!/usr/bin/env runghc
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}

import Language.Haskell.Interpreter
  (setImportsQ, interpret, runInterpreter, as, MonadInterpreter,
   InterpreterError (..), GhcError (..))
import Data.IORef (newIORef, readIORef, writeIORef)
import System.Environment (getArgs, getProgName)
import System.IO
       (openFile, openBinaryFile, hClose, stdin, IOMode (ReadMode), hIsEOF,
        hGetChar, Handle, hSetBinaryMode, stdout, stderr, hPutStrLn)
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Console.CmdArgs.Implicit
  (cmdArgs, (&=), Data, Typeable, help, explicit, name, args, summary, program,
   details)
import System.Exit (exitWith, ExitCode (..))
import Control.Exception (finally, evaluate)
import Control.Monad     (when, liftM, join)

main = do
  myName <- getProgName
  opts <- cmdArgs (eddie &= program myName)
  case parseOpts opts of
    Left e -> do hPutStrLn stderr $ "usage: " ++ myName ++ " " ++ e
                 exitWith (ExitFailure 1)
    Right o -> runIt myName o
      where runIt name opts = do
              let opener = if binary opts then openBinaryFile else openFile
              let outputFunc = putStrMaybeLn (binary opts)
              when (binary opts) $ hSetBinaryMode stdout True
              fun <- runInterpreter $ makeFun opts
              case fun of
                Left e -> do hPutStrLn stderr $ name ++ ": Error: " ++ interpreterErrorMsg e
                             exitWith (ExitFailure 2)
                Right f -> withFiles (files opts) opener (outputFunc . f)


interpreterErrorMsg :: InterpreterError -> String
interpreterErrorMsg err = case err of
  UnknownError msg      -> "Unknown error: " ++ msg
  WontCompile ghcErrors -> "GHC errors:\n" ++ concatMap errMsg ghcErrors
  NotAllowed msg        -> "Not allowed: " ++ msg
  GhcException msg      -> "GHC exceptions: " ++ msg


putStrMaybeLn :: Bool -> String -> IO ()
putStrMaybeLn binary val =
  (if binary || last val == '\n' then putStr else putStrLn) val


makeFun :: MonadInterpreter m => Eddie -> m ([(FilePath, String)] -> String)
makeFun opts = do
  setImportsQ (asModules opts)
  eval (head (expr opts)) mode
    where mode | line opts && list opts = Mode (as :: [String] -> [String]) id
                                               (lines . concat . map snd) unlines
               | line opts = Mode (as :: String -> String) map
                                  (lines . concat . map snd) unlines
               | file opts && list opts = Mode (as :: [String] -> [String]) id
                                               (map snd) concat
               | file opts = Mode (as :: String -> String) map (map snd) concat
               | otherwise = Mode (as :: String -> String) id (concat . map snd)
                                  id


data Mode where
    Mode :: (Typeable a, Typeable b)
         => (a -> b)                    -- witness to `interpret`
         -> ((a -> b) -> c -> d)        -- application of interpreted function
         -> ([(FilePath, String)] -> c) -- preprocess
         -> (d -> String)               -- postprocess
         -> Mode

eval :: MonadInterpreter m => String
                           -> Mode -> m ([(FilePath, String)] -> String)
eval s (Mode f t bra ket) = liftM ((ket .) . (. bra) . t) $ interpret s f

-- an even lazier version of  withFile (courtesy of Heinrich Apfelmus)
-- Tweaked by mwm to accept a handle instead of a file so caller can
-- use favorite opening function or pass in stdin.
withFile :: IO Handle -> (String -> IO a) -> IO a
withFile ih f = do
    fin <- newIORef (return ())
    h <- ih
    let close = join (readIORef fin)
        open  = do
          writeIORef fin (hClose h)
          lazyRead h
    finally (unsafeInterleaveIO open >>= f >>= evaluate) close

    where lazyRead h = hIsEOF h >>= \b ->
            if b
            then do hClose h; return []
            else do c  <- hGetChar h
                    cs <- unsafeInterleaveIO $ lazyRead h
                    return (c:cs)


withFiles :: [FilePath] -> (FilePath -> IOMode -> IO Handle) ->
             ([(FilePath, String)] -> IO a) -> IO a
withFiles []     o f = withFile (return stdin) (\s -> f [("", s)])
withFiles [x]    o f = withFile (o x ReadMode) (\s -> f [(x, s)])
withFiles (x:xs) o f = withFile (o x ReadMode) $ \s ->
    let f' t = f ((x, s):t) in withFiles xs o f'


-- argument processing
data Eddie = Eddie { line :: Bool,
                     file :: Bool,
                     list :: Bool,
                     withNames :: Bool,
                     binary :: Bool,
                     expr :: [String],
                     files :: [String],
                     modules :: [String],
                     asModules :: [(String, Maybe String)]
                   } deriving (Show, Data, Typeable)

parseOpts :: Eddie -> Either String Eddie
parseOpts opts =
  let es = expr opts
      fs = files opts
      e:fs' = case (es, fs) of
        ([], []) -> [""]
        ([], _) -> fs
        (_, _) -> unlines es:fs
      mods = zip (modules opts) (repeat Nothing) ++ asModules opts
  in
   if e == "" || (file opts && null fs') || (file opts && line opts)
              || (list opts && not (file opts || line opts))
   then Left $ unlines ["[options] (-e expr | expr) [files ...]",
                                   "--help for options"]
   else Right $ opts {expr = [e], asModules = mods, files = fs' }


eddie = Eddie {line = False &= help "Process one line at a time (conflicts with --file)",
               file = False &= help "Process files individually (requires at least one file name)",
               list = False &= help "Process the list of files/lines (requires --line or --file)" &= name "L",
               withNames = False &= help "Prepends file name to output lines (conflicts with --list, requires --line or --file and at least one file name)"
               &= explicit &= name "name" &= name "n",
               binary = False &= help "Process binary data",
               expr = [] &= help "Line of expression to evaluate" &= name "e",
               modules = ["Prelude", "Data.List", "Data.Char"]
                         &= help "Modules to import for expr",
               asModules = [] &= help "Modules to import qualified" &= explicit
                           &= name "M" &= name "Modules",
               files = [] &= args}
        &= summary "eddie 0.6" &= details ["Haskell for shell scripts."]