{-# 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"

-- | 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 =
  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

-- | like `getInputLine`, but error if fails
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

-- | 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 =
  (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

-- | like `getInputChar`, but error if fails
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

-- | get password
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)

-- | run a prompt
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

-- | 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 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

-- | 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 -> 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

-- | 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 = (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)

-- | repeat prompt if input returned within milliseconds
-- This prevents buffered stdin lines from being used.
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