{-# OPTIONS_HADDOCK hide #-}

-- |
--
-- Copyright:
--   This file is part of the package byline. It is subject to the
--   license terms in the LICENSE file found in the top-level
--   directory of this distribution and at:
--
--     https://github.com/pjones/byline
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the
--   terms contained in the LICENSE file.
--
-- License: BSD-2-Clause
module Byline.Internal.Eval
  ( MonadByline (..),
    BylineT,
    runBylineT,
    Settings (..),
    defaultBylineSettings,
    runBylineT',
    defaultRenderMode,
  )
where

import Byline.Internal.Completion
import Byline.Internal.Prim (PrimF (..))
import Byline.Internal.Stylized
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Cont (ContT, MonadCont)
import Control.Monad.Except (MonadError)
import qualified Control.Monad.State.Lazy as LState
import qualified Control.Monad.Trans.Free.Church as Free
import qualified System.Console.ANSI as ANSI
import qualified System.Console.Haskeline as Haskeline
import qualified System.Environment as System
import qualified System.Terminfo as Terminfo
import qualified System.Terminfo.Caps as Terminfo

-- | A class of types that can lift Byline operations into a base
-- monad.
--
-- @since 1.0.0.0
class Monad m => MonadByline (m :: * -> *) where
  liftByline :: Free.F PrimF a -> m a
  default liftByline :: (MonadTrans t, MonadByline m1, m ~ t m1) => Free.F PrimF a -> m a
  liftByline = m1 a -> t m1 a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m1 a -> t m1 a) -> (F PrimF a -> m1 a) -> F PrimF a -> t m1 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F PrimF a -> m1 a
forall (m :: * -> *) a. MonadByline m => F PrimF a -> m a
liftByline

instance MonadByline m => MonadByline (ExceptT e m)

instance MonadByline m => MonadByline (StateT s m)

instance MonadByline m => MonadByline (LState.StateT s m)

instance MonadByline m => MonadByline (ReaderT r m)

instance MonadByline m => MonadByline (IdentityT m)

instance MonadByline m => MonadByline (ContT r m)

-- | A monad transformer that implements 'MonadByline'.
--
-- @since 1.0.0.0
newtype BylineT m a = BylineT
  {BylineT m a -> FT PrimF m a
unBylineT :: Free.FT PrimF m a}
  deriving newtype
    ( a -> BylineT m b -> BylineT m a
(a -> b) -> BylineT m a -> BylineT m b
(forall a b. (a -> b) -> BylineT m a -> BylineT m b)
-> (forall a b. a -> BylineT m b -> BylineT m a)
-> Functor (BylineT m)
forall a b. a -> BylineT m b -> BylineT m a
forall a b. (a -> b) -> BylineT m a -> BylineT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> BylineT m b -> BylineT m a
forall (m :: * -> *) a b. (a -> b) -> BylineT m a -> BylineT m b
<$ :: a -> BylineT m b -> BylineT m a
$c<$ :: forall (m :: * -> *) a b. a -> BylineT m b -> BylineT m a
fmap :: (a -> b) -> BylineT m a -> BylineT m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> BylineT m a -> BylineT m b
Functor,
      Functor (BylineT m)
a -> BylineT m a
Functor (BylineT m)
-> (forall a. a -> BylineT m a)
-> (forall a b. BylineT m (a -> b) -> BylineT m a -> BylineT m b)
-> (forall a b c.
    (a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c)
-> (forall a b. BylineT m a -> BylineT m b -> BylineT m b)
-> (forall a b. BylineT m a -> BylineT m b -> BylineT m a)
-> Applicative (BylineT m)
BylineT m a -> BylineT m b -> BylineT m b
BylineT m a -> BylineT m b -> BylineT m a
BylineT m (a -> b) -> BylineT m a -> BylineT m b
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
forall a. a -> BylineT m a
forall a b. BylineT m a -> BylineT m b -> BylineT m a
forall a b. BylineT m a -> BylineT m b -> BylineT m b
forall a b. BylineT m (a -> b) -> BylineT m a -> BylineT m b
forall a b c.
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
forall (m :: * -> *). Functor (BylineT m)
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *) a. a -> BylineT m a
forall (m :: * -> *) a b. BylineT m a -> BylineT m b -> BylineT m a
forall (m :: * -> *) a b. BylineT m a -> BylineT m b -> BylineT m b
forall (m :: * -> *) a b.
BylineT m (a -> b) -> BylineT m a -> BylineT m b
forall (m :: * -> *) a b c.
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
<* :: BylineT m a -> BylineT m b -> BylineT m a
$c<* :: forall (m :: * -> *) a b. BylineT m a -> BylineT m b -> BylineT m a
*> :: BylineT m a -> BylineT m b -> BylineT m b
$c*> :: forall (m :: * -> *) a b. BylineT m a -> BylineT m b -> BylineT m b
liftA2 :: (a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
$cliftA2 :: forall (m :: * -> *) a b c.
(a -> b -> c) -> BylineT m a -> BylineT m b -> BylineT m c
<*> :: BylineT m (a -> b) -> BylineT m a -> BylineT m b
$c<*> :: forall (m :: * -> *) a b.
BylineT m (a -> b) -> BylineT m a -> BylineT m b
pure :: a -> BylineT m a
$cpure :: forall (m :: * -> *) a. a -> BylineT m a
$cp1Applicative :: forall (m :: * -> *). Functor (BylineT m)
Applicative,
      Applicative (BylineT m)
a -> BylineT m a
Applicative (BylineT m)
-> (forall a b. BylineT m a -> (a -> BylineT m b) -> BylineT m b)
-> (forall a b. BylineT m a -> BylineT m b -> BylineT m b)
-> (forall a. a -> BylineT m a)
-> Monad (BylineT m)
BylineT m a -> (a -> BylineT m b) -> BylineT m b
BylineT m a -> BylineT m b -> BylineT m b
forall a. a -> BylineT m a
forall a b. BylineT m a -> BylineT m b -> BylineT m b
forall a b. BylineT m a -> (a -> BylineT m b) -> BylineT m b
forall (m :: * -> *). Applicative (BylineT m)
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *) a. a -> BylineT m a
forall (m :: * -> *) a b. BylineT m a -> BylineT m b -> BylineT m b
forall (m :: * -> *) a b.
BylineT m a -> (a -> BylineT m b) -> BylineT m b
return :: a -> BylineT m a
$creturn :: forall (m :: * -> *) a. a -> BylineT m a
>> :: BylineT m a -> BylineT m b -> BylineT m b
$c>> :: forall (m :: * -> *) a b. BylineT m a -> BylineT m b -> BylineT m b
>>= :: BylineT m a -> (a -> BylineT m b) -> BylineT m b
$c>>= :: forall (m :: * -> *) a b.
BylineT m a -> (a -> BylineT m b) -> BylineT m b
$cp1Monad :: forall (m :: * -> *). Applicative (BylineT m)
Monad,
      Monad (BylineT m)
Monad (BylineT m)
-> (forall a. IO a -> BylineT m a) -> MonadIO (BylineT m)
IO a -> BylineT m a
forall a. IO a -> BylineT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (BylineT m)
forall (m :: * -> *) a. MonadIO m => IO a -> BylineT m a
liftIO :: IO a -> BylineT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> BylineT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (BylineT m)
MonadIO,
      MonadState s,
      MonadReader r,
      MonadError e,
      Monad (BylineT m)
Monad (BylineT m)
-> (forall a b. ((a -> BylineT m b) -> BylineT m a) -> BylineT m a)
-> MonadCont (BylineT m)
((a -> BylineT m b) -> BylineT m a) -> BylineT m a
forall a b. ((a -> BylineT m b) -> BylineT m a) -> BylineT m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall (m :: * -> *). MonadCont m => Monad (BylineT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> BylineT m b) -> BylineT m a) -> BylineT m a
callCC :: ((a -> BylineT m b) -> BylineT m a) -> BylineT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> BylineT m b) -> BylineT m a) -> BylineT m a
$cp1MonadCont :: forall (m :: * -> *). MonadCont m => Monad (BylineT m)
MonadCont,
      Monad (BylineT m)
e -> BylineT m a
Monad (BylineT m)
-> (forall e a. Exception e => e -> BylineT m a)
-> MonadThrow (BylineT m)
forall e a. Exception e => e -> BylineT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (BylineT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> BylineT m a
throwM :: e -> BylineT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> BylineT m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (BylineT m)
MonadThrow,
      MonadThrow (BylineT m)
MonadThrow (BylineT m)
-> (forall e a.
    Exception e =>
    BylineT m a -> (e -> BylineT m a) -> BylineT m a)
-> MonadCatch (BylineT m)
BylineT m a -> (e -> BylineT m a) -> BylineT m a
forall e a.
Exception e =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *). MonadCatch m => MonadThrow (BylineT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a
catch :: BylineT m a -> (e -> BylineT m a) -> BylineT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
BylineT m a -> (e -> BylineT m a) -> BylineT m a
$cp1MonadCatch :: forall (m :: * -> *). MonadCatch m => MonadThrow (BylineT m)
MonadCatch
    )

instance MonadTrans BylineT where
  lift :: m a -> BylineT m a
lift = FT PrimF m a -> BylineT m a
forall (m :: * -> *) a. FT PrimF m a -> BylineT m a
BylineT (FT PrimF m a -> BylineT m a)
-> (m a -> FT PrimF m a) -> m a -> BylineT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> FT PrimF m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadByline (BylineT m) where
  liftByline :: F PrimF a -> BylineT m a
liftByline = FT PrimF m a -> BylineT m a
forall (m :: * -> *) a. FT PrimF m a -> BylineT m a
BylineT (FT PrimF m a -> BylineT m a)
-> (F PrimF a -> FT PrimF m a) -> F PrimF a -> BylineT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F PrimF a -> FT PrimF m a
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
F f a -> m a
Free.fromF

-- | Mutable list of completion functions.
--
-- @since 1.0.0.0
type CompRef m = IORef [CompletionFunc m]

-- | Discharge the 'MonadByline' effect by running all operations and
-- returning the result in the base monad.
--
-- The result is wrapped in a 'Maybe' where a 'Nothing' value
-- indicates that an end-of-file (EOF) signal was received while
-- reading user input.
--
-- @since 1.0.0.0
runBylineT ::
  (MonadIO m, MonadMask m) =>
  BylineT m a ->
  m (Maybe a)
runBylineT :: BylineT m a -> m (Maybe a)
runBylineT = Settings -> BylineT m a -> m (Maybe a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings -> BylineT m a -> m (Maybe a)
runBylineT' Settings
defaultBylineSettings

-- | Settings that control Byline at run time.
--
-- @since 1.0.0.0
data Settings = Settings
  { -- | The output handle to write to.  If 'Nothing' use standard
    -- output.
    --
    -- NOTE: This only affects Byline (i.e. functions that use
    -- @say@).  Functions like @ask@ that invoke Haskeline will always
    -- use standard output since that's the hard-coded default.
    Settings -> Maybe Handle
bylineOutput :: Maybe Handle,
    -- | The input handle to read from.  If 'Nothing' use standard
    -- input.
    Settings -> Maybe Handle
bylineInput :: Maybe Handle,
    -- | Override the detected render mode.
    --
    -- If 'Nothing' use the render mode that is calculated based on
    -- the type of handle Byline writes to.
    Settings -> Maybe RenderMode
bylineMode :: Maybe RenderMode
  }

-- | The default Byline settings.
--
-- @since 1.0.0.0
defaultBylineSettings :: Settings
defaultBylineSettings :: Settings
defaultBylineSettings = Maybe Handle -> Maybe Handle -> Maybe RenderMode -> Settings
Settings Maybe Handle
forall a. Maybe a
Nothing Maybe Handle
forall a. Maybe a
Nothing Maybe RenderMode
forall a. Maybe a
Nothing

-- | Like 'runBylineT' except you can override the settings.
--
-- @since 1.0.0.0
runBylineT' ::
  forall m a.
  (MonadIO m, MonadMask m) =>
  Settings ->
  BylineT m a ->
  m (Maybe a)
runBylineT' :: Settings -> BylineT m a -> m (Maybe a)
runBylineT' Settings {Maybe Handle
Maybe RenderMode
bylineMode :: Maybe RenderMode
bylineInput :: Maybe Handle
bylineOutput :: Maybe Handle
bylineMode :: Settings -> Maybe RenderMode
bylineInput :: Settings -> Maybe Handle
bylineOutput :: Settings -> Maybe Handle
..} BylineT m a
m = do
  IORef [CompletionFunc IO]
compRef <- [CompletionFunc IO] -> m (IORef [CompletionFunc IO])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
  let settings :: Settings m
settings =
        CompletionFunc m -> Settings m -> Settings m
forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
Haskeline.setComplete
          (IORef [CompletionFunc IO] -> CompletionFunc m
compFunc IORef [CompletionFunc IO]
compRef)
          Settings m
forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings
  let behavior :: Behavior
behavior =
        Behavior -> (Handle -> Behavior) -> Maybe Handle -> Behavior
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          Behavior
Haskeline.defaultBehavior
          Handle -> Behavior
Haskeline.useFileHandle
          Maybe Handle
bylineInput
  let hOut :: Handle
hOut = Handle -> Maybe Handle -> Handle
forall a. a -> Maybe a -> a
fromMaybe Handle
stdout Maybe Handle
bylineOutput
  Behavior -> Settings m -> InputT m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Behavior -> Settings m -> InputT m a -> m a
Haskeline.runInputTBehavior Behavior
behavior Settings m
settings (IORef [CompletionFunc IO] -> Handle -> InputT m (Maybe a)
go IORef [CompletionFunc IO]
compRef Handle
hOut)
  where
    compFunc :: CompRef IO -> Haskeline.CompletionFunc m
    compFunc :: IORef [CompletionFunc IO] -> CompletionFunc m
compFunc IORef [CompletionFunc IO]
compRef (String, String)
input = IO (String, [Completion]) -> m (String, [Completion])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, [Completion]) -> m (String, [Completion]))
-> IO (String, [Completion]) -> m (String, [Completion])
forall a b. (a -> b) -> a -> b
$
      IORef [CompletionFunc IO] -> IO [CompletionFunc IO]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [CompletionFunc IO]
compRef IO [CompletionFunc IO]
-> ([CompletionFunc IO] -> IO (String, [Completion]))
-> IO (String, [Completion])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> CompletionFunc IO
forall (m :: * -> *). MonadIO m => CompletionFunc m
Haskeline.completeFilename (String, String)
input
        [CompletionFunc IO]
fs -> [CompletionFunc IO] -> CompletionFunc IO
forall (m :: * -> *).
Monad m =>
[CompletionFunc m] -> CompletionFunc m
runCompletionFunctions [CompletionFunc IO]
fs (String, String)
input
    go ::
      CompRef IO ->
      Handle ->
      Haskeline.InputT m (Maybe a)
    go :: IORef [CompletionFunc IO] -> Handle -> InputT m (Maybe a)
go IORef [CompletionFunc IO]
compRef Handle
hOut = do
      RenderMode
mode <- InputT m RenderMode
-> (RenderMode -> InputT m RenderMode)
-> Maybe RenderMode
-> InputT m RenderMode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO RenderMode -> InputT m RenderMode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO RenderMode
defaultRenderMode Handle
hOut)) RenderMode -> InputT m RenderMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe RenderMode
bylineMode
      BylineT m a -> FT PrimF m a
forall (m :: * -> *) a. BylineT m a -> FT PrimF m a
unBylineT BylineT m a
m
        FT PrimF m a -> (FT PrimF m a -> EvalT m a) -> EvalT m a
forall a b. a -> (a -> b) -> b
& RenderMode
-> Handle -> IORef [CompletionFunc IO] -> FT PrimF m a -> EvalT m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RenderMode
-> Handle -> IORef [CompletionFunc IO] -> FT PrimF m a -> EvalT m a
evalPrimF RenderMode
mode Handle
hOut IORef [CompletionFunc IO]
compRef
        EvalT m a
-> (EvalT m a -> MaybeT (InputT m) a) -> MaybeT (InputT m) a
forall a b. a -> (a -> b) -> b
& EvalT m a -> MaybeT (InputT m) a
forall (m :: * -> *) a. EvalT m a -> MaybeT (InputT m) a
unEvalT
        MaybeT (InputT m) a
-> (MaybeT (InputT m) a -> InputT m (Maybe a))
-> InputT m (Maybe a)
forall a b. a -> (a -> b) -> b
& MaybeT (InputT m) a -> InputT m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT

-- | Internal transformer for evaluating primitive operations in the
-- 'Haskeline.InputT' transformer with EOF handling.
--
-- @since 1.0.0.0
newtype EvalT m a = EvalT
  {EvalT m a -> MaybeT (InputT m) a
unEvalT :: MaybeT (Haskeline.InputT m) a}
  deriving newtype (a -> EvalT m b -> EvalT m a
(a -> b) -> EvalT m a -> EvalT m b
(forall a b. (a -> b) -> EvalT m a -> EvalT m b)
-> (forall a b. a -> EvalT m b -> EvalT m a) -> Functor (EvalT m)
forall a b. a -> EvalT m b -> EvalT m a
forall a b. (a -> b) -> EvalT m a -> EvalT m b
forall (m :: * -> *) a b. Functor m => a -> EvalT m b -> EvalT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EvalT m a -> EvalT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EvalT m b -> EvalT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> EvalT m b -> EvalT m a
fmap :: (a -> b) -> EvalT m a -> EvalT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EvalT m a -> EvalT m b
Functor, Functor (EvalT m)
a -> EvalT m a
Functor (EvalT m)
-> (forall a. a -> EvalT m a)
-> (forall a b. EvalT m (a -> b) -> EvalT m a -> EvalT m b)
-> (forall a b c.
    (a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c)
-> (forall a b. EvalT m a -> EvalT m b -> EvalT m b)
-> (forall a b. EvalT m a -> EvalT m b -> EvalT m a)
-> Applicative (EvalT m)
EvalT m a -> EvalT m b -> EvalT m b
EvalT m a -> EvalT m b -> EvalT m a
EvalT m (a -> b) -> EvalT m a -> EvalT m b
(a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
forall a. a -> EvalT m a
forall a b. EvalT m a -> EvalT m b -> EvalT m a
forall a b. EvalT m a -> EvalT m b -> EvalT m b
forall a b. EvalT m (a -> b) -> EvalT m a -> EvalT m b
forall a b c. (a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
forall (m :: * -> *). Monad m => Functor (EvalT m)
forall (m :: * -> *) a. Monad m => a -> EvalT m a
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m a
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
forall (m :: * -> *) a b.
Monad m =>
EvalT m (a -> b) -> EvalT m a -> EvalT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EvalT m a -> EvalT m b -> EvalT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m a
*> :: EvalT m a -> EvalT m b -> EvalT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
liftA2 :: (a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
<*> :: EvalT m (a -> b) -> EvalT m a -> EvalT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
EvalT m (a -> b) -> EvalT m a -> EvalT m b
pure :: a -> EvalT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> EvalT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (EvalT m)
Applicative, Applicative (EvalT m)
a -> EvalT m a
Applicative (EvalT m)
-> (forall a b. EvalT m a -> (a -> EvalT m b) -> EvalT m b)
-> (forall a b. EvalT m a -> EvalT m b -> EvalT m b)
-> (forall a. a -> EvalT m a)
-> Monad (EvalT m)
EvalT m a -> (a -> EvalT m b) -> EvalT m b
EvalT m a -> EvalT m b -> EvalT m b
forall a. a -> EvalT m a
forall a b. EvalT m a -> EvalT m b -> EvalT m b
forall a b. EvalT m a -> (a -> EvalT m b) -> EvalT m b
forall (m :: * -> *). Monad m => Applicative (EvalT m)
forall (m :: * -> *) a. Monad m => a -> EvalT m a
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> (a -> EvalT m b) -> EvalT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EvalT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> EvalT m a
>> :: EvalT m a -> EvalT m b -> EvalT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
>>= :: EvalT m a -> (a -> EvalT m b) -> EvalT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> (a -> EvalT m b) -> EvalT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (EvalT m)
Monad, Monad (EvalT m)
Monad (EvalT m)
-> (forall a. IO a -> EvalT m a) -> MonadIO (EvalT m)
IO a -> EvalT m a
forall a. IO a -> EvalT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (EvalT m)
forall (m :: * -> *) a. MonadIO m => IO a -> EvalT m a
liftIO :: IO a -> EvalT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> EvalT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (EvalT m)
MonadIO)

instance MonadTrans EvalT where
  lift :: m a -> EvalT m a
lift = MaybeT (InputT m) a -> EvalT m a
forall (m :: * -> *) a. MaybeT (InputT m) a -> EvalT m a
EvalT (MaybeT (InputT m) a -> EvalT m a)
-> (m a -> MaybeT (InputT m) a) -> m a -> EvalT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m a -> MaybeT (InputT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT m a -> MaybeT (InputT m) a)
-> (m a -> InputT m a) -> m a -> MaybeT (InputT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Evaluate 'PrimF' values.
--
-- @since 1.0.0.0
evalPrimF ::
  forall m a.
  (MonadIO m, MonadMask m) =>
  RenderMode ->
  Handle ->
  CompRef IO ->
  Free.FT PrimF m a ->
  EvalT m a
evalPrimF :: RenderMode
-> Handle -> IORef [CompletionFunc IO] -> FT PrimF m a -> EvalT m a
evalPrimF RenderMode
renderMode Handle
outputHandle IORef [CompletionFunc IO]
compRef = (PrimF (EvalT m a) -> EvalT m a) -> FT PrimF m a -> EvalT m a
forall (f :: * -> *) (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Functor f, Monad m, MonadTrans t, Monad (t m)) =>
(f (t m a) -> t m a) -> FT f m a -> t m a
Free.iterTM PrimF (EvalT m a) -> EvalT m a
go
  where
    go ::
      PrimF (EvalT m a) ->
      EvalT m a
    go :: PrimF (EvalT m a) -> EvalT m a
go = \case
      Say Stylized Text
s EvalT m a
k ->
        IO () -> EvalT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (RenderMode -> Handle -> Stylized Text -> IO ()
render RenderMode
renderMode Handle
outputHandle Stylized Text
s) EvalT m () -> EvalT m a -> EvalT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EvalT m a
k
      AskLn Stylized Text
s Maybe Text
d Text -> EvalT m a
k -> do
        let prompt :: Text
prompt =
              RenderMode -> Stylized Text -> Text
renderText RenderMode
renderMode (Stylized Text -> Text) -> Stylized Text -> Text
forall a b. (a -> b) -> a -> b
$
                Stylized Text
-> (Text -> Stylized Text) -> Maybe Text -> Stylized Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Stylized Text
s (\Text
d' -> Stylized Text
s Stylized Text -> Stylized Text -> Stylized Text
forall a. Semigroup a => a -> a -> a
<> Text -> Stylized Text
text Text
"[" Stylized Text -> Stylized Text -> Stylized Text
forall a. Semigroup a => a -> a -> a
<> Text -> Stylized Text
text Text
d' Stylized Text -> Stylized Text -> Stylized Text
forall a. Semigroup a => a -> a -> a
<> Text -> Stylized Text
text Text
"] ") Maybe Text
d
        InputT m (Maybe String) -> EvalT m (Maybe String)
forall b. InputT m b -> EvalT m b
liftHaskeline (String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
Haskeline.getInputLine (Text -> String
forall a. ToString a => a -> String
toString Text
prompt)) EvalT m (Maybe String) -> (Maybe String -> EvalT m a) -> EvalT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe String
Nothing -> MaybeT (InputT m) a -> EvalT m a
forall (m :: * -> *) a. MaybeT (InputT m) a -> EvalT m a
EvalT MaybeT (InputT m) a
forall (f :: * -> *) a. Alternative f => f a
empty
          Just String
answer
            | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
answer -> Text -> EvalT m a
k (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. Monoid a => a
mempty Maybe Text
d)
            | Bool
otherwise -> Text -> EvalT m a
k (String -> Text
forall a. ToText a => a -> Text
toText String
answer)
      AskChar Stylized Text
s Char -> EvalT m a
k -> do
        let prompt :: String
prompt = Text -> String
forall a. ToString a => a -> String
toString (RenderMode -> Stylized Text -> Text
renderText RenderMode
renderMode Stylized Text
s)
        InputT m (Maybe Char) -> EvalT m (Maybe Char)
forall b. InputT m b -> EvalT m b
liftHaskeline (String -> InputT m (Maybe Char)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe Char)
Haskeline.getInputChar String
prompt) EvalT m (Maybe Char) -> (Maybe Char -> EvalT m a) -> EvalT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe Char
Nothing -> MaybeT (InputT m) a -> EvalT m a
forall (m :: * -> *) a. MaybeT (InputT m) a -> EvalT m a
EvalT MaybeT (InputT m) a
forall (f :: * -> *) a. Alternative f => f a
empty
          Just Char
c -> Char -> EvalT m a
k Char
c
      AskPassword Stylized Text
s Maybe Char
m Text -> EvalT m a
k -> do
        let prompt :: String
prompt = Text -> String
forall a. ToString a => a -> String
toString (RenderMode -> Stylized Text -> Text
renderText RenderMode
renderMode Stylized Text
s)
        InputT m (Maybe String) -> EvalT m (Maybe String)
forall b. InputT m b -> EvalT m b
liftHaskeline (Maybe Char -> String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Maybe Char -> String -> InputT m (Maybe String)
Haskeline.getPassword Maybe Char
m String
prompt) EvalT m (Maybe String) -> (Maybe String -> EvalT m a) -> EvalT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe String
Nothing -> MaybeT (InputT m) a -> EvalT m a
forall (m :: * -> *) a. MaybeT (InputT m) a -> EvalT m a
EvalT MaybeT (InputT m) a
forall (f :: * -> *) a. Alternative f => f a
empty
          Just String
str -> Text -> EvalT m a
k (String -> Text
forall a. ToText a => a -> Text
toText String
str)
      PushCompFunc CompletionFunc IO
f EvalT m a
k ->
        IORef [CompletionFunc IO]
-> ([CompletionFunc IO] -> [CompletionFunc IO]) -> EvalT m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef [CompletionFunc IO]
compRef (CompletionFunc IO
f CompletionFunc IO -> [CompletionFunc IO] -> [CompletionFunc IO]
forall a. a -> [a] -> [a]
:) EvalT m () -> EvalT m a -> EvalT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EvalT m a
k
      PopCompFunc EvalT m a
k ->
        IORef [CompletionFunc IO]
-> ([CompletionFunc IO] -> [CompletionFunc IO]) -> EvalT m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef'
          IORef [CompletionFunc IO]
compRef
          ( \case
              [] -> []
              (CompletionFunc IO
_ : [CompletionFunc IO]
fs) -> [CompletionFunc IO]
fs
          )
          EvalT m () -> EvalT m a -> EvalT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EvalT m a
k
    liftHaskeline :: Haskeline.InputT m b -> EvalT m b
    liftHaskeline :: InputT m b -> EvalT m b
liftHaskeline = InputT m b -> InputT m b
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Haskeline.withInterrupt (InputT m b -> InputT m b)
-> (InputT m b -> EvalT m b) -> InputT m b -> EvalT m b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> InputT m b -> MaybeT (InputT m) b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT m b -> MaybeT (InputT m) b)
-> (MaybeT (InputT m) b -> EvalT m b) -> InputT m b -> EvalT m b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MaybeT (InputT m) b -> EvalT m b
forall (m :: * -> *) a. MaybeT (InputT m) a -> EvalT m a
EvalT

-- | Calculate the default rendering mode based on the terminal type.
defaultRenderMode :: Handle -> IO RenderMode
defaultRenderMode :: Handle -> IO RenderMode
defaultRenderMode Handle
hOut = do
  Bool
isTerm <- Handle -> IO Bool
ANSI.hSupportsANSI Handle
hOut
  if Bool
isTerm
    then MaybeT IO Int -> IO (Maybe Int)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT IO Int
getMaxColors IO (Maybe Int) -> (Maybe Int -> IO RenderMode) -> IO RenderMode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Int
Nothing -> RenderMode -> IO RenderMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderMode
Simple
      Just Int
n
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
256 -> RenderMode -> IO RenderMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderMode
Simple
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
256 -> RenderMode -> IO RenderMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderMode
TermRGB
        | Bool
otherwise -> RenderMode -> IO RenderMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderMode
Term256
    else RenderMode -> IO RenderMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenderMode
Plain
  where
    getMaxColors :: MaybeT IO Int
    getMaxColors :: MaybeT IO Int
getMaxColors = do
      String
term <- IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
System.lookupEnv String
"TERM")
      IO (Either String TIDatabase)
-> MaybeT IO (Either String TIDatabase)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> IO (Either String TIDatabase)
Terminfo.acquireDatabase String
term) MaybeT IO (Either String TIDatabase)
-> (Either String TIDatabase -> MaybeT IO Int) -> MaybeT IO Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left String
_ -> MaybeT IO Int
forall (f :: * -> *) a. Alternative f => f a
empty
        Right TIDatabase
db ->
          Maybe Int -> MaybeT IO Int
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Maybe Int -> MaybeT IO Int) -> Maybe Int -> MaybeT IO Int
forall a b. (a -> b) -> a -> b
$
            TIDatabase -> NumTermCap -> Maybe Int
Terminfo.queryNumTermCap TIDatabase
db NumTermCap
Terminfo.MaxColors