#!/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