eddie
Artifact Content
Not logged in
Public Repositories
mwm's Repositories

Artifact d40bf50282c6f2cc219f97023b316f1aad8f14d9:


#!/usr/bin/env runhaskell
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

import ClassyPrelude hiding ((<>))

import Data.Bifunctor (second)
import Data.Version (showVersion)
import Language.Haskell.Interpreter (
  as, interpret, languageExtensions, MonadInterpreter, runInterpreter, set,
  setImportsQ, setUseLanguageExtensions,
  GhcError(..), InterpreterError(..), OptionVal((:=)),
  Extension(NoImplicitPrelude, OverloadedStrings, UnknownExtension))
import Options.Applicative (
  (<>), customExecParser, disambiguate, header, help, helper, hidden,
  info, infoOption, long,  many, metavar, option, prefs, short,
  str, strArgument, strOption, switch, value, Parser)
import Paths_eddie (version)
import Safe (tailMay)
import System.Environment (getProgName)
import System.Exit (exitWith, exitSuccess, ExitCode(..))
import System.IO (hSetBinaryMode, hSetEncoding, mkTextEncoding, openFile,
                 IOMode(ReadMode), TextEncoding)
import Text.Read (read)


{- Data types -}
data Eddie = Eddie -- Command line arguments and options.
                   [String]                 -- exprs
                   Bool			    -- lazy
                   Bool                     -- binary
                   Bool                     -- text
                   Bool                     -- line
                   Bool                     -- file
                   Bool                     -- names
                   Bool                     -- list
                   (Maybe String)           -- encoding
                   (Maybe String)           -- inputEncoding
                   (Maybe String)           -- outputEncoding
                   [String]                 -- modules
                   [(String, Maybe String)] -- asModules
                   [String]                 -- extensions
                   [String]                 -- files
                   deriving (Show)

data Proxy a b = Proxy -- Proxy for input and output data types 

data Mode a b -- Processing mode for the expression
     where Mode :: (IsSequence a, IsSequence b, Typeable b, Typeable c)
                => (c -> b)               -- witness to interpret
                -> (Handle -> IO a)       -- Read input
                -> ([(Text, a)] -> d)     -- preprocess
                -> ((c -> b) -> d -> b)   -- wrapper of interpreted function
                -> (b -> IO ())           -- Write output
                -> Mode a b

data Args = Args -- Arguments for turning the expression into a function
                 String                     -- Expression
                 [String]                   -- Files
                 [(String, Maybe String)]   -- Modules
                 [Extension]                   -- Extensions

data Options = Options -- Options controlling how data is passed to the function
                 Bool                      -- lines
                 Bool                      -- files
                 Bool                      -- names
                 Bool                      -- list
                 (IO (Maybe TextEncoding)) -- input encoding
                 (IO (Maybe TextEncoding)) -- output encoding


main :: IO ()
main = eddie =<< options


-- eddie takes an Eddie and create a Mode then calls eddie' to do the work
eddie :: Eddie -> IO ()
-- Handle usage errors
eddie opts@(Eddie exprs lazy binary text lines files names list
                  encoding input output _ _ _ fileNames)
  | text && not (binary || lazy) =
      printError "Usage: --text requires --binary or --lazy"
  | lines && files = printError "Usage: --lines is incompatible with --files"
  | lines && names = printError "Usage: --lines is incompatible with --names"
  | files && names = printError "Usage: --files is incompatible with --names"
  | files && null fileNames =
      printError "Usage: --files requires at least one file"
  | names && null fileNames =
      printError "Usage: --names requires at least one file"
  | list && not (lines || files || names) =
      printError "Usage: --list requires one of --lines, --files or --names"
  | null fileNames && null exprs = printError "Usage: Must provide an expression"
  | isJust encoding && (isJust input || isJust output) =
      printError "Usage: --encoding is incompatible with --input-encoding and --output-encoding"
  | binary && isJust input =
      printError "Usage: --input-encoding is incompatible with --binary"
  | binary && not text && isJust output =
      printError "Usage: can only use --output-encoding for text output"

-- Shuffle convenience options into the right places
eddie (Eddie [] lazy binary text lines files names list Nothing input output
             modules asModules extensions (expr:fileNames)) =
  eddie (Eddie [expr] lazy binary text lines files names list Nothing input output
               modules asModules extensions fileNames)
eddie (Eddie exprs lazy binary text lines files names list encoding@(Just _) input
             output modules asModules extensions fileNames)
  | not binary = eddie (Eddie exprs lazy binary text lines files names list Nothing
                              encoding encoding modules asModules extensions
                              fileNames)
  | otherwise  = eddie (Eddie exprs lazy binary text lines files names list Nothing
                              Nothing encoding modules asModules extensions
                              fileNames)

-- Sort out the types and pass things to eddie'
eddie (Eddie exprs lazy binary text lines files names list _ input output
             modules asModules extensions fileNames)
  | binary && text && lazy = eddie' (makeBinaryMode
                                     (Proxy :: Proxy LByteString Text) opts
                                     hGetContents $ putMaybeLn outputEncoding)
                           args
  | binary && text = eddie' (makeBinaryMode
                             (Proxy :: Proxy ByteString Text) opts
                             hGetContents $ putMaybeLn outputEncoding)
                            args
  | binary && lazy = eddie' (makeBinaryMode (Proxy ::Proxy LByteString LByteString)
                                            opts hGetContents putBinary)
                            args
  | binary = eddie' (makeBinaryMode (Proxy :: Proxy ByteString ByteString) opts
                                     hGetContents putBinary)
                    args
  | lazy && text = eddie' (makeTextMode (Proxy :: Proxy LText Text) opts) args
  | lazy = eddie' (makeTextMode (Proxy :: Proxy LText LText) opts) args
  | otherwise = eddie' (makeTextMode (Proxy :: Proxy Text Text) opts) args
  where args = Args (unlines exprs) fileNames (makeModules modules asModules)
                    (map makeExtension extensions)
        inputEncoding = mapM mkTextEncoding input
        outputEncoding = mapM mkTextEncoding output
        opts = Options lines files names list inputEncoding outputEncoding

eddie' :: Mode a b -> Args -> IO ()
eddie' mode@(Mode _ reader _ _ writer) args@(Args _ files _ _) = do
  fun <- runInterpreter $ makeFun mode args
  case fun of
   Left e -> printErrorCode 2 $ interpreterErrorMsg e
   Right f -> do
     handles <- if null files then return [stdin]
                              else mapM (flip openFile ReadMode) files
     mapM reader handles >>= writer . f . zip (map fromString files ++ [""])
     exitSuccess


{- Tools for making the various elements used above -}
makeTextMode :: forall a b. (IOData a, Textual a, Typeable a,
                             IOData b, Textual b, Typeable b)
             => Proxy a b -> Options -> Mode a b
makeTextMode proxy opts@(Options line _ _ list input output)
  | not line  = makeBinaryMode proxy opts reader writer
  | list      = Mode (as :: [a] -> b) reader (lines . concatMap snd) id writer
  | otherwise = Mode (as :: a -> b) reader (lines . concatMap snd)
                     (\f -> unlines . map f) writer
  where reader = hGetEncoded input
        writer = putMaybeLn output

makeBinaryMode :: forall a b. (IOData a, Typeable a, IOData b, Typeable b)
               => Proxy a b -> Options -> (Handle -> IO a) -> (b -> IO ())
               -> Mode a b
makeBinaryMode _ (Options _ files names list _ _) reader writer
  | files && list = Mode (as :: [a] -> b) reader (map snd) id writer
  | names && list = Mode (as :: [(Text, a)] -> b) reader id id writer
  | files         = Mode (as :: a -> b) reader (map snd) concatMap writer
  | names         = Mode (as :: (Text, a) -> b) reader id concatMap writer
  | otherwise     = Mode (as :: a -> b) reader (concatMap snd) id writer


makeModules :: [String] -> [(String, Maybe String)] -> [(String, Maybe String)]
makeModules modules asModules = zip modules (repeat Nothing) ++ asModules

makeExtension :: String -> Extension
makeExtension extension =
  fromMaybe (UnknownExtension extension) $ readMay extension


makeFun :: MonadInterpreter m => Mode a b -> Args -> m ([(Text, a)] -> b)
makeFun (Mode witness _ pre wrap _) (Args expr _ modules extensions) = do
  set [languageExtensions := ([NoImplicitPrelude, OverloadedStrings] ++
                              extensions)] 
  setImportsQ (("ClassyPrelude", Nothing):modules)
  liftM ((. pre) . wrap) $ interpret expr witness


{- Argument handling -}
options :: IO Eddie
options = do
  name <- getProgName
  let versionString = showVersion version
      fullName = name ++ " " ++ versionString
  customExecParser (prefs disambiguate)
    $ info (eddieOptions <**> helper <**>
            infoOption fullName (short 'V' <> long "version" <>
                                 help "Print version information") <**>
            infoOption versionString (long "numeric-version" <>
                                      help "Print just the version number"))
           (header $ name ++ " - Haskell for shell scripts")

eddieOptions :: Parser Eddie
eddieOptions =
  Eddie <$> many (strOption (short 'e' <> long "expression" <> metavar "EXPR" <>
                             help "Line of expression to evaluate")) <*>
            switch (long "lazy" <> help "Use lazy data types" <> hidden) <*>
            switch (short 'b' <> long "binary" <> help "Process binary data") <*>
            switch (short 't' <> long "text" <> help "Produce text output") <*>
            switch (short 'l' <> long "lines" <>
                    help "Process one line at a time (conflicts with --files and --names)") <*>
            switch (short 'f' <> long "files" <>
                    help "Process files individually (requires at least one file name)") <*>
            switch (short 'n' <> long "names" <>
                    help "Process files individually as (NAME, DATA) tuples (requires at least one file name)") <*>
            switch (short 'L' <> long "list" <>
                    help "Process the list of files/lines (requires --lines, --files or --names )") <*>
            option (Just <$> str) (long "encoding" <> value Nothing <>
                                   help "Encoding for text file.") <*>
            option (Just <$> str) (long "input-encoding" <> value Nothing <>
                                   help "Encoding for input text file.") <*>
            option (Just <$> str) (long "output-encoding" <> value Nothing <>
                                   help "Encoding for output text file.") <*>
            many (strOption (short 'm' <> long "module" <> metavar "MODULE" <>
                             help "Module to import for expr")) <*>
            many (option (second tailMay . break (== ',') <$> str)
                         (short 'M' <> long "Module" <> metavar "MODULE,AS" <>
                          help "Module to import qualified")) <*>
            many (strOption (short 'X' <> long "extension" <>
                             metavar "EXTENSION" <>
                             help "Extension to enable")) <*>
            many (strArgument (metavar "[EXPR] FILES ..."))


{- Utilities -}
-- Probably sucks the performance right out of Text, but it makes the output
-- pretty. Maybe make it optional?
putBinary :: IOData a => a -> IO ()
putBinary s = hSetBinaryMode stdout True >> hPut stdout s

putMaybeLn :: forall a. (IOData a, Textual a)
            => IO (Maybe TextEncoding) -> a -> IO ()
putMaybeLn encoding out = do
  hSetMaybeEncoding encoding stdout
  putMaybeLn' True out
  where putMaybeLn' newline (uncons -> Nothing) =
          unless newline $ hPut stdout ("\n" :: a)
        putMaybeLn' _ (uncons -> Just (c, cs)) = do
              hPut stdout $ (singleton c :: a)
              putMaybeLn' (c == '\n') cs

hGetEncoded :: IOData a => IO (Maybe TextEncoding) -> Handle -> IO a
hGetEncoded encoding handle = do
  hSetMaybeEncoding encoding handle
  hGetContents handle
  
hSetMaybeEncoding :: IO (Maybe TextEncoding) -> Handle -> IO ()
hSetMaybeEncoding encoding handle =
  encoding >>= maybe (return ()) (hSetEncoding handle)


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

printErrorCode :: Int -> String -> IO ()
printErrorCode code string = do
  name <- getProgName
  hPutStrLn stderr $ name ++ ": " ++ string
  exitWith (ExitFailure code)

printError :: String -> IO ()
printError = printErrorCode 1