eddie-1.0.0: eddie.hs
#!/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