{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
-- |Functions to expedite the building of REPLs.
module System.REPL (
-- *String-generic versions of Prelude Functions
module Data.ListLike.IO,
putErr,
putErrLn,
-- *Feture-rich reading of user-input
-- |These functions automate parsing and validating command-line
-- input via the 'Asker' type.
--
-- It is possible to ask for Strings, but then quotes will be required
-- around them (per their Read-instance). If you want to get the user's
-- input as-is, use the 'Verbatim' type.
Asker(..),
Success(..),
AskFailure(..),
asker,
typeAsker,
predAsker,
maybeAsker,
prompt,
prompt',
Verbatim(..),
-- **Asking for input
ask,
ask',
untilValid,
) where
import Prelude hiding (putStrLn, putStr, getLine)
import Control.Arrow (right, (|||))
import Control.Exception
import Control.Monad.Except
import Data.Char (isSpace)
import Data.Functor.Monadic
import Data.ListLike()
import Data.ListLike.IO (ListLikeIO(..))
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import Data.Typeable
import qualified System.IO as IO
import Text.Read (readMaybe)
-- Stdio
-------------------------------------------------------------------------------
-- |Prints a string to stderr.
putErr :: ListLikeIO full item => full -> IO ()
putErr = hPutStr IO.stderr
-- |Prints a string, followed by a newline character, to stderr.
putErrLn :: ListLikeIO full item => full -> IO ()
putErrLn = hPutStrLn IO.stderr
-- |Prints @> @ and asks the user to input a line.
prompt :: (MonadIO m, Functor m, ListLikeIO full item) => m full
prompt = prompt' ("> " :: String)
-- |Prints its first argument and, in the same line, asks the user
-- to input a line.
prompt' :: (MonadIO m, Functor m, ListLikeIO full item, ListLikeIO full' item')
=> full -> m full'
prompt' s = liftIO (putStr s >> IO.hFlush IO.stdout >> getLine)
-- Askers
-------------------------------------------------------------------------------
-- |The description of an \'ask for user input\'-action.
-- The type parameters are the used monad (typically @IO@),
-- the type of the read value and the type of the error that is thrown
-- in case of failures.
data Asker m a = Asker{ -- |The prompt to be displayed to the user.
askerPrompt::Text,
-- |The parser for the input value, which
-- either delivers a value of type @a@ or
-- an error message.
askerParser::Text -> Either Text a,
-- |The predicate which the input, once read,
-- must fulfill. It either delivers 'Success'
-- or an error message.
askerPredicate::a -> m (Either Text Success)}
-- |Singleton type representing success.
data Success = Success deriving (Eq, Show, Read)
-- |Represents a failure of an ask function.
-- It can either be a type failure (failure to interpret the
-- user input as a value of the required type) or a predicate
-- failure (the user input could be interpreter as a value
-- of the required type, but it failed some user-supplied test).
data AskFailure = TypeFailure Text -- ^Indicates that the parsing as the
-- required type failed.
| PredicateFailure Text -- ^Indiciates that the parsed
-- value failed a predicate.
| ParamFailure Text
-- ^Indicates that an incorrect number of
-- parameters was passed.
| NothingFoundFailure -- ^Indicates that no action was
-- appropriate to the given input.
deriving (Typeable, Eq)
instance Exception AskFailure
instance Show AskFailure where
show (ParamFailure t) = T.unpack t
show NothingFoundFailure = "No appropriate action found!"
show (PredicateFailure t) = T.unpack t
show (TypeFailure t) = T.unpack t
-- |A verbatim Text whose Read instance simply returns the read
-- string, as-is.
-- This is useful for askers which ask for strings without quotes.
newtype Verbatim = Verbatim{fromVerbatim::Text -- ^Extracts a 'Verbatim''s 'Text'.
}
-- |Read-instance for 'Verbatim'. Wraps the given value into quotes and
-- reads it a a 'Text'.
instance Read Verbatim where
readsPrec _ s = [(Verbatim $ T.pack s,"")]
-- |Creates a general 'Asker' with 'Data.Read.readMaybe' as its parser.
-- This suffices for most simple values.
-- The main drawback of using 'Data.Read.readMaybe' is that the input
-- 'Text' is unpacked into a String, which incurs a performance hit.
-- For short (one-line) input. this isn't important, but if large ones
-- are expected, it's better to pass a custom, 'Text'-compatible parsing
-- function, such as a parsec-parser.
asker :: (Monad m, Functor m, Read a)
=> Text -- ^The prompt.
-> Text -- ^Type error message.
-> Text -- ^Predicate error message.
-> (a -> m Bool) -- ^Predicate.
-> Asker m a
asker pr errT errP pred = Asker pr parse check
where
parse = maybe (Left errT) Right . readMaybe . T.unpack
check = pred >=$> (\case True -> Right Success
False -> Left errP)
-- |Creates an 'Asker' which just cares about the type of the input.
typeAsker :: (Monad m, Functor m, Read a)
=> Text -- ^The prompt.
-> Text -- ^Type error message.
-> Asker m a
typeAsker p errT = asker p errT undefined (const $ return True)
-- |Creates an 'Asker' which takes its input verbatim as 'Text'.
predAsker :: (Monad m, Functor m)
=> Text -- ^The prompt.
-> Text -- ^Predicate error message.
-> (Text -> m Bool) -- ^The predicate.
-> Asker m Verbatim
predAsker p errP f = asker p (error "Type error in predAsker. This is a bug.")
errP (f . fromVerbatim)
-- |An asker which asks for an optional value. If only whitespace
-- is entered (according to 'Data.Char.isSpace'), it returns 'Nothing'
-- without further parsing or checking; otherwise, it behaves identically
-- to 'asker'.
maybeAsker :: (Monad m, Functor m, Read a)
=> Text -- ^The prompt.
-> Text -- ^Type error message.
-> Text -- ^Predicate error message.
-> (a -> m Bool) -- ^Predicate.
-> Asker m (Maybe a)
maybeAsker pr errT errP pred = Asker pr parse check
where
parse t = if T.all isSpace t then Right Nothing
else right Just
$ maybe (Left errT) Right
$ readMaybe
$ T.unpack t
check Nothing = return $ Right Success
check (Just t) = pred t >$> (\case True -> Right Success
False -> Left errP)
-- Running askers
--------------------------------------------------------------------------------
-- |Executes an 'Asker'. If the Text argument is Nothing, the user is asked
-- to enter a line on stdin. If it is @Just x@, @x@ is taken to be input.
-- If the input is of the wrong type, an error-message is printed
-- and the user is asked again.
-- In addition to the condition that the input must be of the correct
-- type, it must also fulfill a predicate.
--
-- Since the predicate is of monadic, arbitrarily complex
-- tests can be performed: checking whether an item is in a database,
-- whether a date was less than x years ago, etc.
ask :: (MonadIO m, MonadError SomeException m, Functor m, Read a)
=> Asker m a
-> Maybe Text
-> m a
ask a v = maybe ((liftIO . prompt' . askerPrompt $ a) >>= check)
check
v
where
check inp =
case askerParser a inp of
Left err -> throwError $ SomeException $ TypeFailure err
Right t -> askerPredicate a t
>>= (throwError . SomeException . PredicateFailure ||| return . const t)
-- |See 'ask'. Always reads the input from stdin.
-- @ask' a = ask a Nothing@.
ask' :: (MonadIO m, MonadError SomeException m, Functor m, Read a)
=> Asker m a
-> m a
ask' a = ask a Nothing
-- |Repeatedly executes an ask action until the user enters a valid value.
-- Error messages are printed each time.
untilValid :: (MonadIO m, MonadError SomeException m, Functor m, Read a)
=> m a
-> m a
untilValid m = m `catchError` (\l -> liftIO (putStrLn (show l)) >> untilValid m)