{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Effect.Terminal where

import Control.Algebra
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Data.Functor
import Data.Kind
import Data.Text (Text, pack)
import Prettyprinter
import Prettyprinter.Render.Terminal
import System.Console.Haskeline
import System.IO

data Terminal (m :: Type -> Type) a where
  PrettyPrint :: Handle -> Doc AnsiStyle -> Terminal m ()
  Prompt :: String -> Terminal m (Maybe Text)

prettyPrint :: Has Terminal sig m => Handle -> Doc AnsiStyle -> m ()
prettyPrint :: Handle -> Doc AnsiStyle -> m ()
prettyPrint Handle
handle Doc AnsiStyle
doc = Terminal m () -> m ()
forall (eff :: (Type -> Type) -> Type -> Type)
       (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(Member eff sig, Algebra sig m) =>
eff m a -> m a
send (Terminal m () -> m ()) -> Terminal m () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> Terminal m ()
forall (m :: Type -> Type).
Handle -> Doc AnsiStyle -> Terminal m ()
PrettyPrint Handle
handle (Doc AnsiStyle -> Terminal m ()) -> Doc AnsiStyle -> Terminal m ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
doc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"\n"

prompt :: Has Terminal sig m => String -> m (Maybe Text)
prompt :: String -> m (Maybe Text)
prompt = Terminal m (Maybe Text) -> m (Maybe Text)
forall (eff :: (Type -> Type) -> Type -> Type)
       (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(Member eff sig, Algebra sig m) =>
eff m a -> m a
send (Terminal m (Maybe Text) -> m (Maybe Text))
-> (String -> Terminal m (Maybe Text)) -> String -> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Terminal m (Maybe Text)
forall (m :: Type -> Type). String -> Terminal m (Maybe Text)
Prompt

newtype TerminalC m a = TerminalC {TerminalC m a -> InputT m a
runTerminalC :: InputT m a}
  deriving newtype (a -> TerminalC m b -> TerminalC m a
(a -> b) -> TerminalC m a -> TerminalC m b
(forall a b. (a -> b) -> TerminalC m a -> TerminalC m b)
-> (forall a b. a -> TerminalC m b -> TerminalC m a)
-> Functor (TerminalC m)
forall a b. a -> TerminalC m b -> TerminalC m a
forall a b. (a -> b) -> TerminalC m a -> TerminalC m b
forall (m :: Type -> Type) a b.
Functor m =>
a -> TerminalC m b -> TerminalC m a
forall (m :: Type -> Type) a b.
Functor m =>
(a -> b) -> TerminalC m a -> TerminalC m b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TerminalC m b -> TerminalC m a
$c<$ :: forall (m :: Type -> Type) a b.
Functor m =>
a -> TerminalC m b -> TerminalC m a
fmap :: (a -> b) -> TerminalC m a -> TerminalC m b
$cfmap :: forall (m :: Type -> Type) a b.
Functor m =>
(a -> b) -> TerminalC m a -> TerminalC m b
Functor, Functor (TerminalC m)
a -> TerminalC m a
Functor (TerminalC m)
-> (forall a. a -> TerminalC m a)
-> (forall a b.
    TerminalC m (a -> b) -> TerminalC m a -> TerminalC m b)
-> (forall a b c.
    (a -> b -> c) -> TerminalC m a -> TerminalC m b -> TerminalC m c)
-> (forall a b. TerminalC m a -> TerminalC m b -> TerminalC m b)
-> (forall a b. TerminalC m a -> TerminalC m b -> TerminalC m a)
-> Applicative (TerminalC m)
TerminalC m a -> TerminalC m b -> TerminalC m b
TerminalC m a -> TerminalC m b -> TerminalC m a
TerminalC m (a -> b) -> TerminalC m a -> TerminalC m b
(a -> b -> c) -> TerminalC m a -> TerminalC m b -> TerminalC m c
forall a. a -> TerminalC m a
forall a b. TerminalC m a -> TerminalC m b -> TerminalC m a
forall a b. TerminalC m a -> TerminalC m b -> TerminalC m b
forall a b. TerminalC m (a -> b) -> TerminalC m a -> TerminalC m b
forall a b c.
(a -> b -> c) -> TerminalC m a -> TerminalC m b -> TerminalC m c
forall (f :: Type -> Type).
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 :: Type -> Type). Applicative m => Functor (TerminalC m)
forall (m :: Type -> Type) a. Applicative m => a -> TerminalC m a
forall (m :: Type -> Type) a b.
Applicative m =>
TerminalC m a -> TerminalC m b -> TerminalC m a
forall (m :: Type -> Type) a b.
Applicative m =>
TerminalC m a -> TerminalC m b -> TerminalC m b
forall (m :: Type -> Type) a b.
Applicative m =>
TerminalC m (a -> b) -> TerminalC m a -> TerminalC m b
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> c) -> TerminalC m a -> TerminalC m b -> TerminalC m c
<* :: TerminalC m a -> TerminalC m b -> TerminalC m a
$c<* :: forall (m :: Type -> Type) a b.
Applicative m =>
TerminalC m a -> TerminalC m b -> TerminalC m a
*> :: TerminalC m a -> TerminalC m b -> TerminalC m b
$c*> :: forall (m :: Type -> Type) a b.
Applicative m =>
TerminalC m a -> TerminalC m b -> TerminalC m b
liftA2 :: (a -> b -> c) -> TerminalC m a -> TerminalC m b -> TerminalC m c
$cliftA2 :: forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> c) -> TerminalC m a -> TerminalC m b -> TerminalC m c
<*> :: TerminalC m (a -> b) -> TerminalC m a -> TerminalC m b
$c<*> :: forall (m :: Type -> Type) a b.
Applicative m =>
TerminalC m (a -> b) -> TerminalC m a -> TerminalC m b
pure :: a -> TerminalC m a
$cpure :: forall (m :: Type -> Type) a. Applicative m => a -> TerminalC m a
$cp1Applicative :: forall (m :: Type -> Type). Applicative m => Functor (TerminalC m)
Applicative, Applicative (TerminalC m)
a -> TerminalC m a
Applicative (TerminalC m)
-> (forall a b.
    TerminalC m a -> (a -> TerminalC m b) -> TerminalC m b)
-> (forall a b. TerminalC m a -> TerminalC m b -> TerminalC m b)
-> (forall a. a -> TerminalC m a)
-> Monad (TerminalC m)
TerminalC m a -> (a -> TerminalC m b) -> TerminalC m b
TerminalC m a -> TerminalC m b -> TerminalC m b
forall a. a -> TerminalC m a
forall a b. TerminalC m a -> TerminalC m b -> TerminalC m b
forall a b. TerminalC m a -> (a -> TerminalC m b) -> TerminalC m b
forall (m :: Type -> Type). Monad m => Applicative (TerminalC m)
forall (m :: Type -> Type) a. Monad m => a -> TerminalC m a
forall (m :: Type -> Type) a b.
Monad m =>
TerminalC m a -> TerminalC m b -> TerminalC m b
forall (m :: Type -> Type) a b.
Monad m =>
TerminalC m a -> (a -> TerminalC m b) -> TerminalC m b
forall (m :: Type -> Type).
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 -> TerminalC m a
$creturn :: forall (m :: Type -> Type) a. Monad m => a -> TerminalC m a
>> :: TerminalC m a -> TerminalC m b -> TerminalC m b
$c>> :: forall (m :: Type -> Type) a b.
Monad m =>
TerminalC m a -> TerminalC m b -> TerminalC m b
>>= :: TerminalC m a -> (a -> TerminalC m b) -> TerminalC m b
$c>>= :: forall (m :: Type -> Type) a b.
Monad m =>
TerminalC m a -> (a -> TerminalC m b) -> TerminalC m b
$cp1Monad :: forall (m :: Type -> Type). Monad m => Applicative (TerminalC m)
Monad, Monad (TerminalC m)
Monad (TerminalC m)
-> (forall a. IO a -> TerminalC m a) -> MonadIO (TerminalC m)
IO a -> TerminalC m a
forall a. IO a -> TerminalC m a
forall (m :: Type -> Type).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: Type -> Type). MonadIO m => Monad (TerminalC m)
forall (m :: Type -> Type) a. MonadIO m => IO a -> TerminalC m a
liftIO :: IO a -> TerminalC m a
$cliftIO :: forall (m :: Type -> Type) a. MonadIO m => IO a -> TerminalC m a
$cp1MonadIO :: forall (m :: Type -> Type). MonadIO m => Monad (TerminalC m)
MonadIO)

runTerminal' :: (MonadIO m, MonadMask m) => Settings m -> TerminalC m a -> m a
runTerminal' :: Settings m -> TerminalC m a -> m a
runTerminal' Settings m
s = Settings m -> InputT m a -> m a
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings m
s (InputT m a -> m a)
-> (TerminalC m a -> InputT m a) -> TerminalC m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminalC m a -> InputT m a
forall (m :: Type -> Type) a. TerminalC m a -> InputT m a
runTerminalC

runTerminal :: (MonadIO m, MonadMask m) => TerminalC m a -> m a
runTerminal :: TerminalC m a -> m a
runTerminal = Settings m -> TerminalC m a -> m a
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
Settings m -> TerminalC m a -> m a
runTerminal' (Settings m -> TerminalC m a -> m a)
-> Settings m -> TerminalC m a -> m a
forall a b. (a -> b) -> a -> b
$ CompletionFunc m -> Settings m -> Settings m
forall (m :: Type -> Type).
CompletionFunc m -> Settings m -> Settings m
setComplete CompletionFunc m
forall (m :: Type -> Type). Monad m => CompletionFunc m
noCompletion Settings m
forall (m :: Type -> Type). MonadIO m => Settings m
defaultSettings

instance (MonadMask m, MonadIO m, Algebra sig m) => Algebra (Terminal :+: sig) (TerminalC m) where
  alg :: Handler ctx n (TerminalC m)
-> (:+:) Terminal sig n a -> ctx () -> TerminalC m (ctx a)
alg Handler ctx n (TerminalC m)
hdl (:+:) Terminal sig n a
sig ctx ()
ctx = InputT m (ctx a) -> TerminalC m (ctx a)
forall (m :: Type -> Type) a. InputT m a -> TerminalC m a
TerminalC (InputT m (ctx a) -> TerminalC m (ctx a))
-> InputT m (ctx a) -> TerminalC m (ctx a)
forall a b. (a -> b) -> a -> b
$
    case (:+:) Terminal sig n a
sig of
      L (PrettyPrint Handle
handle Doc AnsiStyle
doc) -> do
        IO () -> InputT m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT m ()) -> IO () -> InputT m ()
forall a b. (a -> b) -> a -> b
$ Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO Handle
handle (SimpleDocStream AnsiStyle -> IO ())
-> SimpleDocStream AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions Doc AnsiStyle
doc
        ctx () -> InputT m (ctx ())
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ctx () -> InputT m (ctx ())) -> ctx () -> InputT m (ctx ())
forall a b. (a -> b) -> a -> b
$ ctx ()
ctx ctx () -> () -> ctx ()
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> ()
      L (Prompt String
p) -> do
        Maybe String
res <- String -> InputT m (Maybe String)
forall (m :: Type -> Type).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
p
        ctx (Maybe Text) -> InputT m (ctx (Maybe Text))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ctx (Maybe Text) -> InputT m (ctx (Maybe Text)))
-> ctx (Maybe Text) -> InputT m (ctx (Maybe Text))
forall a b. (a -> b) -> a -> b
$ ctx ()
ctx ctx () -> Maybe Text -> ctx (Maybe Text)
forall (f :: Type -> Type) a b. Functor f => f a -> b -> f b
$> (String -> Text) -> Maybe String -> Maybe Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
pack Maybe String
res
      R sig n a
other -> ((forall a. InputT m a -> m a) -> m (ctx a)) -> InputT m (ctx a)
forall (m :: Type -> Type) b.
Monad m =>
((forall a. InputT m a -> m a) -> m b) -> InputT m b
withRunInBase (((forall a. InputT m a -> m a) -> m (ctx a)) -> InputT m (ctx a))
-> ((forall a. InputT m a -> m a) -> m (ctx a)) -> InputT m (ctx a)
forall a b. (a -> b) -> a -> b
$ \forall a. InputT m a -> m a
runInput -> Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (sig :: (Type -> Type) -> Type -> Type) (m :: Type -> Type)
       (ctx :: Type -> Type) (n :: Type -> Type) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (InputT m (ctx x) -> m (ctx x)
forall a. InputT m a -> m a
runInput (InputT m (ctx x) -> m (ctx x))
-> (ctx (n x) -> InputT m (ctx x)) -> ctx (n x) -> m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminalC m (ctx x) -> InputT m (ctx x)
forall (m :: Type -> Type) a. TerminalC m a -> InputT m a
runTerminalC (TerminalC m (ctx x) -> InputT m (ctx x))
-> (ctx (n x) -> TerminalC m (ctx x))
-> ctx (n x)
-> InputT m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx (n x) -> TerminalC m (ctx x)
Handler ctx n (TerminalC m)
hdl) sig n a
other ctx ()
ctx