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