{-# LANGUAGE CPP #-}

module SimplePrompt.Internal (
  getPromptLine,
  getPromptInitial,
  getPromptChar,
  getPromptPassword,
  getGenericPrompt,
  runPrompt,
  untilInput,
  mapInput,
  nonEmptyInput,
  timedInput,
  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 System.Console.Haskeline

#include "../monadconstraint.h"

-- | generic prompt wrapper
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 =
  String -> InputT m (Maybe a)
prompter (String
s forall a. [a] -> [a] -> [a]
++ String
": ") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"could not read input!") forall (m :: * -> *) a. Monad m => a -> m a
return

-- | like getInputLine, but error if fails
getPromptLine :: MONADCONSTRAINT => String -> InputT m String
getPromptLine :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptLine =
  forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine

-- | like getPromptLine, but with initial input
getPromptInitial :: MONADCONSTRAINT => String -> String -> InputT m String
getPromptInitial :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> String -> InputT m String
getPromptInitial String
s String
i =
  forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt (forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> (String, String) -> InputT m (Maybe String)
`getInputLineWithInitial` (String
i,String
"")) String
s

-- | like getInputChar, but error if fails
getPromptChar :: MONADCONSTRAINT => String -> InputT m Char
getPromptChar :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m Char
getPromptChar =
  forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe Char)
getInputChar

-- | get password
getPromptPassword :: MONADCONSTRAINT => String -> InputT m String
getPromptPassword :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m String
getPromptPassword =
  forall (m :: * -> *) a.
MonadIO m =>
(String -> InputT m (Maybe a)) -> String -> InputT m a
getGenericPrompt (forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Maybe Char -> String -> InputT m (Maybe String)
getPassword forall a. Maybe a
Nothing)

-- | run a prompt
runPrompt :: MONADCONSTRAINT => InputT m a -> m a
runPrompt :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> m a
runPrompt =  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT forall (m :: * -> *). MonadIO m => Settings m
defaultSettings

-- | loop prompt until check
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 forall (m :: * -> *) a. Monad m => a -> m a
return a
input
    else forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(a -> Bool) -> InputT m a -> InputT m a
untilInput a -> Bool
p InputT m a
prompting

-- | maybe map input or loop prompt
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
    Maybe b
Nothing -> 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

-- | repeat prompt until non-empty
nonEmptyInput :: MONADCONSTRAINT => InputT m String -> InputT m String
nonEmptyInput :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
InputT m String -> InputT m String
nonEmptyInput = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(a -> Bool) -> InputT m a -> InputT m a
untilInput (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)

-- | repeat prompt if input returned within milliseconds
timedInput :: MonadIO m => InputT m a -> InputT m a
timedInput :: forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
timedInput InputT m a
prompter = do
  UTCTime
start <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  a
input <- InputT m a
prompter
  UTCTime
end <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let diff :: NominalDiffTime
diff = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
end UTCTime
start
  if NominalDiffTime
diff forall a. Ord a => a -> a -> Bool
< NominalDiffTime
0.005
    then do
    forall (m :: * -> *). MonadIO m => String -> InputT m ()
outputStrLn forall a b. (a -> b) -> a -> b
$ String
"ignoring buffered input: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show NominalDiffTime
diff forall a. [a] -> [a] -> [a]
++ String
" too quick"
    forall (m :: * -> *) a. MonadIO m => InputT m a -> InputT m a
timedInput InputT m a
prompter
    else forall (m :: * -> *) a. Monad m => a -> m a
return a
input