{-# LANGUAGE CPP #-}
module SimplePrompt.Internal (
getPromptLine,
getPromptInitial,
getPromptChar,
getPromptPassword,
getGenericPrompt,
runPrompt,
untilInput,
mapInput,
nonEmptyInput,
clearedInput,
MonadIO,
#if MIN_VERSION_haskeline(0,8,0)
MonadMask
#else
MonadException
#endif
) where
#if MIN_VERSION_haskeline(0,8,0)
import Control.Monad.Catch (MonadMask)
#endif
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Safe (lastMay)
import System.Console.Haskeline
#include "../monadconstraint.h"
getGenericPrompt :: MonadIO m => (String -> InputT m (Maybe a))
-> String -> InputT m a
getGenericPrompt :: forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt String -> InputT m (Maybe a)
prompter String
s =
let suff :: String
suff =
case String -> Maybe Char
forall a. [a] -> Maybe a
lastMay String
s of
Just Char
'\n' -> String
""
Just Char
':' -> String
" "
Maybe Char
_ -> String
": "
in
String -> InputT m (Maybe a)
prompter (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suff) InputT m (Maybe a) -> (Maybe a -> InputT m a) -> InputT m a
forall a b. InputT m a -> (a -> InputT m b) -> InputT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
InputT m a -> (a -> InputT m a) -> Maybe a -> InputT m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> InputT m a
forall a. HasCallStack => String -> a
error String
"could not read input!") a -> InputT m a
forall a. a -> InputT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
getPromptLine :: MONADCONSTRAINT => String -> InputT m String
getPromptLine :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine =
(String -> InputT m (Maybe String)) -> String -> InputT m String
forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine
getPromptInitial :: MONADCONSTRAINT => String -> String -> InputT m String
getPromptInitial :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> String -> InputT m String
getPromptInitial String
s String
i =
(String -> InputT m (Maybe String)) -> String -> InputT m String
forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt (String -> (String, String) -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> (String, String) -> InputT m (Maybe String)
`getInputLineWithInitial` (String
i,String
"")) String
s
getPromptChar :: MONADCONSTRAINT => String -> InputT m Char
getPromptChar :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m Char
getPromptChar =
(String -> InputT m (Maybe Char)) -> String -> InputT m Char
forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt String -> InputT m (Maybe Char)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe Char)
getInputChar
getPromptPassword :: MONADCONSTRAINT => String -> InputT m String
getPromptPassword :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptPassword =
(String -> InputT m (Maybe String)) -> String -> InputT m String
forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt (Maybe Char -> String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Maybe Char -> String -> InputT m (Maybe String)
getPassword Maybe Char
forall a. Maybe a
Nothing)
runPrompt :: MONADCONSTRAINT => InputT m a -> m a
runPrompt :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt = Settings m -> InputT m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings m
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings
untilInput :: MONADCONSTRAINT => (a -> Bool) -> InputT m a -> InputT m a
untilInput :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(a -> Bool) -> InputT m a -> InputT m a
untilInput a -> Bool
p InputT m a
prompting = do
a
input <- InputT m a
prompting
if a -> Bool
p a
input
then a -> InputT m a
forall a. a -> InputT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
input
else (a -> Bool) -> InputT m a -> InputT m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(a -> Bool) -> InputT m a -> InputT m a
untilInput a -> Bool
p InputT m a
prompting
mapInput :: MONADCONSTRAINT => (a -> Maybe b) -> InputT m a -> InputT m b
mapInput :: forall (m :: * -> *) a b.
(MonadIO m, MonadMask m) =>
(a -> Maybe b) -> InputT m a -> InputT m b
mapInput a -> Maybe b
f InputT m a
prompting = do
a
input <- InputT m a
prompting
case a -> Maybe b
f a
input of
Just b
x -> b -> InputT m b
forall a. a -> InputT m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
Maybe b
Nothing -> (a -> Maybe b) -> InputT m a -> InputT m b
forall (m :: * -> *) a b.
(MonadIO m, MonadMask m) =>
(a -> Maybe b) -> InputT m a -> InputT m b
mapInput a -> Maybe b
f InputT m a
prompting
nonEmptyInput :: MONADCONSTRAINT => InputT m String -> InputT m String
nonEmptyInput :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
InputT m String -> InputT m String
nonEmptyInput = (String -> Bool) -> InputT m String -> InputT m String
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(a -> Bool) -> InputT m a -> InputT m a
untilInput (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
clearedInput :: MonadIO m => InputT m a -> InputT m a
clearedInput :: forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput InputT m a
prompter = do
UTCTime
start <- IO UTCTime -> InputT m UTCTime
forall a. IO a -> InputT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
a
input <- InputT m a
prompter
UTCTime
end <- IO UTCTime -> InputT m UTCTime
forall a. IO a -> InputT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end UTCTime
start NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
0.005
then do
String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn String
"dropped buffered input"
InputT m a -> InputT m a
forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
clearedInput InputT m a
prompter
else a -> InputT m a
forall a. a -> InputT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
input