eddie-0.5: eddie.hs

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

-- import Data.ByteString.Lazy (readFile)
import Language.Haskell.Interpreter
  (setImportsQ, interpret, runInterpreter, as, MonadInterpreter)
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: " ++ show e
                             exitWith (ExitFailure 2)
                Right f -> withFiles (files opts) opener (outputFunc . f)

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


makeFun :: MonadInterpreter m => Eddie -> m ([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) unlines
               | line opts = Mode (as :: String -> String) map 
                                  (lines . concat) unlines
               | file opts && list opts = Mode (as :: [String] -> [String]) id 
                                               id concat
               | file opts = Mode (as :: String -> String) map id concat
               | otherwise = Mode (as :: String -> String) id concat id


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

eval :: MonadInterpreter m => String -> Mode -> m ([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) -> 
             ([String] -> IO a) -> IO a
withFiles []     o f = withFile (return stdin) (f . (:[]))
withFiles [x]    o f = withFile (o x ReadMode) (f . (:[]))
withFiles (x:xs) o f = withFile (o x ReadMode) $ \s ->
    let f' t = f (s:t) in withFiles xs o f'


-- argument processing
data Eddie = Eddie { line :: Bool,
                     file :: Bool,
                     list :: 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",
               binary = False &= help "Process a binary file",
               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.5" &= details ["Haskell for shell scripts."]