{-# LANGUAGE CPP #-}

{- ORMOLU_DISABLE -}

module Effects.Haskeline

#if MIN_VERSION_base(4,19,0)

{-# WARNING in "x-experimental" "Effects.Haskeline is experimental and subject to change." #-}

#else

{-# WARNING "Effects.Haskeline is experimental (not deprecated) and subject to change." #-}

#endif

  ( -- * Class
    MonadHaskeline (..),

    -- * IO Runners
    H.runInputT,
    H.runInputTBehavior,
    H.runInputTBehaviorWithPrefs,

    -- * Config
    H.defaultSettings,
    H.defaultBehavior,
    H.defaultPrefs,
  )
where

{- ORMOLU_ENABLE -}

import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import GHC.Stack (HasCallStack)
import System.Console.Haskeline (InputT)
import System.Console.Haskeline qualified as H
import System.Console.Haskeline.History (History)

-- NOTE: We implement most of the effectful functions from
-- System.Console.Haskeline. What is missing is functions of the form
-- 'foo :: Input m a -> m a' i.e. they run the input to produce a result in the
-- underlying monad.
--
-- It is not obvious how to add such functionality here since we chose to
-- return functions in the class parameter m, rather than InputT m. We
-- chose this because e.g. lifting to ReaderT was straightforward. Otherwise
-- we would have to write a 'hoist :: InputT (ReaderT e m) a -> InputT m a',
-- and this is also not obvious.
--
-- One way we might implement functions like foo is to include an associated
-- type 'type Base m' ana have 'foo :: m a -> Base m a'.
class (Monad m) => MonadHaskeline m where
  -- | Lifted 'H.haveTerminalUI'.
  --
  -- @since 0.1
  haveTerminalUI :: (HasCallStack) => m Bool

  -- | Lifted 'H.getInputLine'.
  --
  -- @since 0.1
  getInputLine :: (HasCallStack) => String -> m (Maybe String)

  -- | Lifted 'H.getInputLineWithInitial'.
  --
  -- @since 0.1
  getInputLineWithInitial :: (HasCallStack) => String -> (String, String) -> m (Maybe String)

  -- | Lifted 'H.getInputChar'.
  --
  -- @since 0.1
  getInputChar :: (HasCallStack) => String -> m (Maybe Char)

  -- | Lifted 'H.getPassword'.
  --
  -- @since 0.1
  getPassword :: (HasCallStack) => Maybe Char -> String -> m (Maybe String)

  -- | Lifted 'H.waitForAnyKey'.
  --
  -- @since 0.1
  waitForAnyKey :: (HasCallStack) => String -> m Bool

  -- | Lifted 'H.outputStr'.
  --
  -- @since 0.1
  outputStr :: (HasCallStack) => String -> m ()

  -- | Lifted 'H.outputStrLn'.
  --
  -- @since 0.1
  outputStrLn :: (HasCallStack) => String -> m ()

  -- | Lifted 'H.getHistory'.
  --
  -- @since 0.1
  getHistory :: (HasCallStack) => m History

  -- | Lifted 'H.putHistory'.
  --
  -- @since 0.1
  putHistory :: (HasCallStack) => History -> m ()

  -- | Lifted 'H.modifyHistory'.
  --
  -- @since 0.1
  modifyHistory :: (HasCallStack) => (History -> History) -> m ()

  -- | Lifted 'H.withInterrupt'.
  --
  -- @since 0.1
  withInterrupt :: (HasCallStack) => m a -> m a

  -- | Lifted 'H.handleInterrupt'.
  --
  -- @since 0.1
  handleInterrupt :: (HasCallStack) => m a -> m a -> m a

instance (MonadIO m, MonadMask m) => MonadHaskeline (InputT m) where
  haveTerminalUI :: HasCallStack => InputT m Bool
haveTerminalUI = InputT m Bool
forall (m :: * -> *). Monad m => InputT m Bool
H.haveTerminalUI
  {-# INLINEABLE haveTerminalUI #-}
  getInputLine :: HasCallStack => String -> InputT m (Maybe String)
getInputLine = String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
H.getInputLine
  {-# INLINEABLE getInputLine #-}
  getInputLineWithInitial :: HasCallStack =>
String -> (String, String) -> InputT m (Maybe String)
getInputLineWithInitial = String -> (String, String) -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> (String, String) -> InputT m (Maybe String)
H.getInputLineWithInitial
  {-# INLINEABLE getInputLineWithInitial #-}
  getInputChar :: HasCallStack => String -> InputT m (Maybe Char)
getInputChar = String -> InputT m (Maybe Char)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe Char)
H.getInputChar
  {-# INLINEABLE getInputChar #-}
  getPassword :: HasCallStack => Maybe Char -> String -> InputT m (Maybe String)
getPassword = Maybe Char -> String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Maybe Char -> String -> InputT m (Maybe String)
H.getPassword
  {-# INLINEABLE getPassword #-}
  waitForAnyKey :: HasCallStack => String -> InputT m Bool
waitForAnyKey = String -> InputT m Bool
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m Bool
H.waitForAnyKey
  {-# INLINEABLE waitForAnyKey #-}
  outputStr :: HasCallStack => String -> InputT m ()
outputStr = String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
H.outputStr
  {-# INLINEABLE outputStr #-}
  outputStrLn :: HasCallStack => String -> InputT m ()
outputStrLn = String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
H.outputStrLn
  {-# INLINEABLE outputStrLn #-}
  getHistory :: HasCallStack => InputT m History
getHistory = InputT m History
forall (m :: * -> *). MonadIO m => InputT m History
H.getHistory
  {-# INLINEABLE getHistory #-}
  putHistory :: HasCallStack => History -> InputT m ()
putHistory = History -> InputT m ()
forall (m :: * -> *). MonadIO m => History -> InputT m ()
H.putHistory
  {-# INLINEABLE putHistory #-}
  modifyHistory :: HasCallStack => (History -> History) -> InputT m ()
modifyHistory = (History -> History) -> InputT m ()
forall (m :: * -> *).
MonadIO m =>
(History -> History) -> InputT m ()
H.modifyHistory
  {-# INLINEABLE modifyHistory #-}
  withInterrupt :: forall a. HasCallStack => InputT m a -> InputT m a
withInterrupt = InputT m a -> InputT m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
H.withInterrupt
  {-# INLINEABLE withInterrupt #-}
  handleInterrupt :: forall a. HasCallStack => InputT m a -> InputT m a -> InputT m a
handleInterrupt = InputT m a -> InputT m a -> InputT m a
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
H.handleInterrupt
  {-# INLINEABLE handleInterrupt #-}

instance (MonadHaskeline m) => MonadHaskeline (ReaderT e m) where
  haveTerminalUI :: HasCallStack => ReaderT e m Bool
haveTerminalUI = m Bool -> ReaderT e m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
forall (m :: * -> *). (MonadHaskeline m, HasCallStack) => m Bool
haveTerminalUI
  {-# INLINEABLE haveTerminalUI #-}
  getInputLine :: HasCallStack => String -> ReaderT e m (Maybe String)
getInputLine = m (Maybe String) -> ReaderT e m (Maybe String)
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe String) -> ReaderT e m (Maybe String))
-> (String -> m (Maybe String))
-> String
-> ReaderT e m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Maybe String)
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
String -> m (Maybe String)
getInputLine
  {-# INLINEABLE getInputLine #-}
  getInputLineWithInitial :: HasCallStack =>
String -> (String, String) -> ReaderT e m (Maybe String)
getInputLineWithInitial String
s = m (Maybe String) -> ReaderT e m (Maybe String)
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe String) -> ReaderT e m (Maybe String))
-> ((String, String) -> m (Maybe String))
-> (String, String)
-> ReaderT e m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String) -> m (Maybe String)
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
String -> (String, String) -> m (Maybe String)
getInputLineWithInitial String
s
  {-# INLINEABLE getInputLineWithInitial #-}
  getInputChar :: HasCallStack => String -> ReaderT e m (Maybe Char)
getInputChar = m (Maybe Char) -> ReaderT e m (Maybe Char)
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe Char) -> ReaderT e m (Maybe Char))
-> (String -> m (Maybe Char)) -> String -> ReaderT e m (Maybe Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Maybe Char)
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
String -> m (Maybe Char)
getInputChar
  {-# INLINEABLE getInputChar #-}
  getPassword :: HasCallStack => Maybe Char -> String -> ReaderT e m (Maybe String)
getPassword Maybe Char
c = m (Maybe String) -> ReaderT e m (Maybe String)
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe String) -> ReaderT e m (Maybe String))
-> (String -> m (Maybe String))
-> String
-> ReaderT e m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> String -> m (Maybe String)
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
Maybe Char -> String -> m (Maybe String)
getPassword Maybe Char
c
  {-# INLINEABLE getPassword #-}
  waitForAnyKey :: HasCallStack => String -> ReaderT e m Bool
waitForAnyKey = m Bool -> ReaderT e m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ReaderT e m Bool)
-> (String -> m Bool) -> String -> ReaderT e m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m Bool
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
String -> m Bool
waitForAnyKey
  {-# INLINEABLE waitForAnyKey #-}
  outputStr :: HasCallStack => String -> ReaderT e m ()
outputStr = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (String -> m ()) -> String -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
String -> m ()
outputStr
  {-# INLINEABLE outputStr #-}
  outputStrLn :: HasCallStack => String -> ReaderT e m ()
outputStrLn = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (String -> m ()) -> String -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
String -> m ()
outputStrLn
  {-# INLINEABLE outputStrLn #-}
  getHistory :: HasCallStack => ReaderT e m History
getHistory = m History -> ReaderT e m History
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m History
forall (m :: * -> *). (MonadHaskeline m, HasCallStack) => m History
getHistory
  {-# INLINEABLE getHistory #-}
  putHistory :: HasCallStack => History -> ReaderT e m ()
putHistory = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (History -> m ()) -> History -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. History -> m ()
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
History -> m ()
putHistory
  {-# INLINEABLE putHistory #-}
  modifyHistory :: HasCallStack => (History -> History) -> ReaderT e m ()
modifyHistory = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> ((History -> History) -> m ())
-> (History -> History)
-> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (History -> History) -> m ()
forall (m :: * -> *).
(MonadHaskeline m, HasCallStack) =>
(History -> History) -> m ()
modifyHistory
  {-# INLINEABLE modifyHistory #-}
  withInterrupt :: forall a. HasCallStack => ReaderT e m a -> ReaderT e m a
withInterrupt ReaderT e m a
rdr = ReaderT e m e
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT e m e -> (e -> ReaderT e m a) -> ReaderT e m a
forall a b. ReaderT e m a -> (a -> ReaderT e m b) -> ReaderT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \e
env -> m a -> ReaderT e m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT e m a) -> m a -> ReaderT e m a
forall a b. (a -> b) -> a -> b
$ m a -> m a
forall a. HasCallStack => m a -> m a
forall (m :: * -> *) a.
(MonadHaskeline m, HasCallStack) =>
m a -> m a
withInterrupt (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT e m a -> e -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT e m a
rdr e
env
  {-# INLINEABLE withInterrupt #-}
  handleInterrupt :: forall a.
HasCallStack =>
ReaderT e m a -> ReaderT e m a -> ReaderT e m a
handleInterrupt ReaderT e m a
m1 ReaderT e m a
m2 =
    ReaderT e m e
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT e m e -> (e -> ReaderT e m a) -> ReaderT e m a
forall a b. ReaderT e m a -> (a -> ReaderT e m b) -> ReaderT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \e
env ->
      m a -> ReaderT e m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT e m a) -> m a -> ReaderT e m a
forall a b. (a -> b) -> a -> b
$ m a -> m a -> m a
forall a. HasCallStack => m a -> m a -> m a
forall (m :: * -> *) a.
(MonadHaskeline m, HasCallStack) =>
m a -> m a -> m a
handleInterrupt (ReaderT e m a -> e -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT e m a
m1 e
env) (ReaderT e m a -> e -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT e m a
m2 e
env)
  {-# INLINEABLE handleInterrupt #-}