{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Simplex.Chat.Terminal.Output where

import Control.Concurrent (ThreadId)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.Reader
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands (execChatCommand, execChatCommand')
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))
import Simplex.Chat.Options
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
import Simplex.Chat.Remote.Types (RHKey (..), RemoteHostId, RemoteHostInfo (..), RemoteHostSession (..))
import Simplex.Chat.Styled
import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
import Simplex.Chat.Types
import Simplex.Chat.View
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util (tshow)
import System.Console.ANSI.Types
import System.IO (IOMode (..), hPutStrLn, withFile)
import System.Mem.Weak (Weak)
import System.Terminal
import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
import UnliftIO.STM

data ChatTerminal = ChatTerminal
  { ChatTerminal -> TerminalDevice
termDevice :: TerminalDevice,
    ChatTerminal -> TVar TerminalState
termState :: TVar TerminalState,
    ChatTerminal -> Size
termSize :: Size,
    ChatTerminal -> TVar (Maybe LiveMessage)
liveMessageState :: TVar (Maybe LiveMessage),
    ChatTerminal -> TVar Int
nextMessageRow :: TVar Int,
    ChatTerminal -> TMVar ()
termLock :: TMVar (),
    ChatTerminal -> Maybe (Notification -> IO ())
sendNotification :: Maybe (Notification -> IO ()),
    ChatTerminal -> TVar String
activeTo :: TVar String,
    ChatTerminal -> TMap RemoteHostId User
currentRemoteUsers :: TMap RemoteHostId User
  }

data TerminalState = TerminalState
  { TerminalState -> String
inputPrompt :: String,
    TerminalState -> String
inputString :: String,
    TerminalState -> Int
inputPosition :: Int,
    TerminalState -> String
previousInput :: String,
    TerminalState -> AutoCompleteState
autoComplete :: AutoCompleteState
  }

data ACShowVariants = SVNone | SVSome | SVAll
  deriving (ACShowVariants -> ACShowVariants -> Bool
(ACShowVariants -> ACShowVariants -> Bool)
-> (ACShowVariants -> ACShowVariants -> Bool) -> Eq ACShowVariants
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ACShowVariants -> ACShowVariants -> Bool
== :: ACShowVariants -> ACShowVariants -> Bool
$c/= :: ACShowVariants -> ACShowVariants -> Bool
/= :: ACShowVariants -> ACShowVariants -> Bool
Eq, Int -> ACShowVariants
ACShowVariants -> Int
ACShowVariants -> [ACShowVariants]
ACShowVariants -> ACShowVariants
ACShowVariants -> ACShowVariants -> [ACShowVariants]
ACShowVariants
-> ACShowVariants -> ACShowVariants -> [ACShowVariants]
(ACShowVariants -> ACShowVariants)
-> (ACShowVariants -> ACShowVariants)
-> (Int -> ACShowVariants)
-> (ACShowVariants -> Int)
-> (ACShowVariants -> [ACShowVariants])
-> (ACShowVariants -> ACShowVariants -> [ACShowVariants])
-> (ACShowVariants -> ACShowVariants -> [ACShowVariants])
-> (ACShowVariants
    -> ACShowVariants -> ACShowVariants -> [ACShowVariants])
-> Enum ACShowVariants
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ACShowVariants -> ACShowVariants
succ :: ACShowVariants -> ACShowVariants
$cpred :: ACShowVariants -> ACShowVariants
pred :: ACShowVariants -> ACShowVariants
$ctoEnum :: Int -> ACShowVariants
toEnum :: Int -> ACShowVariants
$cfromEnum :: ACShowVariants -> Int
fromEnum :: ACShowVariants -> Int
$cenumFrom :: ACShowVariants -> [ACShowVariants]
enumFrom :: ACShowVariants -> [ACShowVariants]
$cenumFromThen :: ACShowVariants -> ACShowVariants -> [ACShowVariants]
enumFromThen :: ACShowVariants -> ACShowVariants -> [ACShowVariants]
$cenumFromTo :: ACShowVariants -> ACShowVariants -> [ACShowVariants]
enumFromTo :: ACShowVariants -> ACShowVariants -> [ACShowVariants]
$cenumFromThenTo :: ACShowVariants
-> ACShowVariants -> ACShowVariants -> [ACShowVariants]
enumFromThenTo :: ACShowVariants
-> ACShowVariants -> ACShowVariants -> [ACShowVariants]
Enum)

data AutoCompleteState = ACState
  { AutoCompleteState -> [String]
acVariants :: [String],
    AutoCompleteState -> String
acInputString :: String,
    AutoCompleteState -> Bool
acTabPressed :: Bool,
    AutoCompleteState -> ACShowVariants
acShowVariants :: ACShowVariants
  }

data LiveMessage = LiveMessage
  { LiveMessage -> ChatName
chatName :: ChatName,
    LiveMessage -> RemoteHostId
chatItemId :: ChatItemId,
    LiveMessage -> Bool
livePrompt :: Bool,
    LiveMessage -> String
sentMsg :: String,
    LiveMessage -> String
typedMsg :: String,
    LiveMessage -> Weak ThreadId
liveThreadId :: Weak ThreadId,
    LiveMessage -> Weak ThreadId
promptThreadId :: Weak ThreadId
  }

class Terminal t => WithTerminal t where
  withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a

data TerminalDevice = forall t. WithTerminal t => TerminalDevice t

instance WithTerminal LocalTerminal where
  withTerm :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
LocalTerminal -> (LocalTerminal -> m a) -> m a
withTerm LocalTerminal
_ = (LocalTerminal -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(LocalTerminal -> m a) -> m a
withTerminal

instance WithTerminal VirtualTerminal where
  withTerm :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
VirtualTerminal -> (VirtualTerminal -> m a) -> m a
withTerm VirtualTerminal
t = ((VirtualTerminal -> m a) -> VirtualTerminal -> m a
forall a b. (a -> b) -> a -> b
$ VirtualTerminal
t)

withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ChatTerminal
-> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal {termDevice :: ChatTerminal -> TerminalDevice
termDevice = TerminalDevice t
t} forall t. WithTerminal t => TerminalT t m a
action = t -> (t -> m a) -> m a
forall t (m :: * -> *) a.
(WithTerminal t, MonadIO m, MonadMask m) =>
t -> (t -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
t -> (t -> m a) -> m a
withTerm t
t ((t -> m a) -> m a) -> (t -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ TerminalT t m a -> t -> m a
forall (m :: * -> *) t a.
(MonadIO m, MonadMask m, Terminal t) =>
TerminalT t m a -> t -> m a
runTerminalT TerminalT t m a
forall t. WithTerminal t => TerminalT t m a
action

newChatTerminal :: WithTerminal t => t -> ChatOpts -> IO ChatTerminal
newChatTerminal :: forall t. WithTerminal t => t -> ChatOpts -> IO ChatTerminal
newChatTerminal t
t ChatOpts
opts = do
  Size
termSize <- t -> (t -> IO Size) -> IO Size
forall t (m :: * -> *) a.
(WithTerminal t, MonadIO m, MonadMask m) =>
t -> (t -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
t -> (t -> m a) -> m a
withTerm t
t ((t -> IO Size) -> IO Size)
-> (TerminalT t IO Size -> t -> IO Size)
-> TerminalT t IO Size
-> IO Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminalT t IO Size -> t -> IO Size
forall (m :: * -> *) t a.
(MonadIO m, MonadMask m, Terminal t) =>
TerminalT t m a -> t -> m a
runTerminalT (TerminalT t IO Size -> IO Size) -> TerminalT t IO Size -> IO Size
forall a b. (a -> b) -> a -> b
$ TerminalT t IO Size
forall (m :: * -> *). MonadScreen m => m Size
getWindowSize
  let lastRow :: Int
lastRow = Size -> Int
height Size
termSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  TVar TerminalState
termState <- TerminalState -> IO (TVar TerminalState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO TerminalState
mkTermState
  TVar (Maybe LiveMessage)
liveMessageState <- Maybe LiveMessage -> IO (TVar (Maybe LiveMessage))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe LiveMessage
forall a. Maybe a
Nothing
  TMVar ()
termLock <- () -> IO (TMVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (TMVar a)
newTMVarIO ()
  TVar Int
nextMessageRow <- Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
lastRow
  Maybe (Notification -> IO ())
sendNotification <- if ChatOpts -> Bool
muteNotifications ChatOpts
opts then Maybe (Notification -> IO ()) -> IO (Maybe (Notification -> IO ()))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Notification -> IO ())
forall a. Maybe a
Nothing else (Notification -> IO ()) -> Maybe (Notification -> IO ())
forall a. a -> Maybe a
Just ((Notification -> IO ()) -> Maybe (Notification -> IO ()))
-> IO (Notification -> IO ()) -> IO (Maybe (Notification -> IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Notification -> IO ())
initializeNotifications
  TVar String
activeTo <- String -> IO (TVar String)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO String
""
  TMap RemoteHostId User
currentRemoteUsers <- Map RemoteHostId User -> IO (TMap RemoteHostId User)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map RemoteHostId User
forall a. Monoid a => a
mempty
  -- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
  ChatTerminal -> IO ChatTerminal
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ChatTerminal
      { termDevice :: TerminalDevice
termDevice = t -> TerminalDevice
forall t. WithTerminal t => t -> TerminalDevice
TerminalDevice t
t,
        TVar TerminalState
termState :: TVar TerminalState
termState :: TVar TerminalState
termState,
        Size
termSize :: Size
termSize :: Size
termSize,
        TVar (Maybe LiveMessage)
liveMessageState :: TVar (Maybe LiveMessage)
liveMessageState :: TVar (Maybe LiveMessage)
liveMessageState,
        TVar Int
nextMessageRow :: TVar Int
nextMessageRow :: TVar Int
nextMessageRow,
        TMVar ()
termLock :: TMVar ()
termLock :: TMVar ()
termLock,
        Maybe (Notification -> IO ())
sendNotification :: Maybe (Notification -> IO ())
sendNotification :: Maybe (Notification -> IO ())
sendNotification,
        TVar String
activeTo :: TVar String
activeTo :: TVar String
activeTo,
        TMap RemoteHostId User
currentRemoteUsers :: TMap RemoteHostId User
currentRemoteUsers :: TMap RemoteHostId User
currentRemoteUsers
      }

mkTermState :: TerminalState
mkTermState :: TerminalState
mkTermState =
  TerminalState
    { inputString :: String
inputString = String
"",
      inputPosition :: Int
inputPosition = Int
0,
      inputPrompt :: String
inputPrompt = String
"> ",
      previousInput :: String
previousInput = String
"",
      autoComplete :: AutoCompleteState
autoComplete = AutoCompleteState
mkAutoComplete
    }

mkAutoComplete :: AutoCompleteState
mkAutoComplete :: AutoCompleteState
mkAutoComplete = ACState {acVariants :: [String]
acVariants = [], acInputString :: String
acInputString = String
"", acTabPressed :: Bool
acTabPressed = Bool
False, acShowVariants :: ACShowVariants
acShowVariants = ACShowVariants
SVNone}

withTermLock :: MonadTerminal m => ChatTerminal -> m () -> m ()
withTermLock :: forall (m :: * -> *).
MonadTerminal m =>
ChatTerminal -> m () -> m ()
withTermLock ChatTerminal {TMVar ()
termLock :: ChatTerminal -> TMVar ()
termLock :: TMVar ()
termLock} m ()
action = do
  ()
_ <- STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
termLock
  m ()
action
  STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
termLock ()

runTerminalOutput :: ChatTerminal -> ChatController -> ChatOpts -> IO ()
runTerminalOutput :: ChatTerminal -> ChatController -> ChatOpts -> IO ()
runTerminalOutput ChatTerminal
ct cc :: ChatController
cc@ChatController {TBQueue (Maybe RemoteHostId, Either ChatError ChatEvent)
outputQ :: TBQueue (Maybe RemoteHostId, Either ChatError ChatEvent)
outputQ :: ChatController
-> TBQueue (Maybe RemoteHostId, Either ChatError ChatEvent)
outputQ, TVar Bool
showLiveItems :: TVar Bool
showLiveItems :: ChatController -> TVar Bool
showLiveItems, Maybe String
logFilePath :: Maybe String
logFilePath :: ChatController -> Maybe String
logFilePath} ChatOpts {Bool
markRead :: Bool
markRead :: ChatOpts -> Bool
markRead} = do
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (Maybe RemoteHostId
outputRH, Either ChatError ChatEvent
r_) <- STM (Maybe RemoteHostId, Either ChatError ChatEvent)
-> IO (Maybe RemoteHostId, Either ChatError ChatEvent)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RemoteHostId, Either ChatError ChatEvent)
 -> IO (Maybe RemoteHostId, Either ChatError ChatEvent))
-> STM (Maybe RemoteHostId, Either ChatError ChatEvent)
-> IO (Maybe RemoteHostId, Either ChatError ChatEvent)
forall a b. (a -> b) -> a -> b
$ TBQueue (Maybe RemoteHostId, Either ChatError ChatEvent)
-> STM (Maybe RemoteHostId, Either ChatError ChatEvent)
forall a. TBQueue a -> STM a
readTBQueue TBQueue (Maybe RemoteHostId, Either ChatError ChatEvent)
outputQ
    Either ChatError ChatEvent -> (ChatEvent -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Either ChatError ChatEvent
r_ ((ChatEvent -> IO ()) -> IO ()) -> (ChatEvent -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
      CEvtNewChatItems User
u (AChatItem
ci : [AChatItem]
_) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
markRead (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> IO ()
markChatItemRead User
u AChatItem
ci -- At the moment of writing received items are created one at a time
      CEvtChatItemUpdated User
u AChatItem
ci -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
markRead (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ User -> AChatItem -> IO ()
markChatItemRead User
u AChatItem
ci
      CEvtRemoteHostConnected {remoteHost :: ChatEvent -> RemoteHostInfo
remoteHost = RemoteHostInfo {RemoteHostId
remoteHostId :: RemoteHostId
remoteHostId :: RemoteHostInfo -> RemoteHostId
remoteHostId}} -> RemoteHostId -> IO ()
getRemoteUser RemoteHostId
remoteHostId
      CEvtRemoteHostStopped {Maybe RemoteHostId
remoteHostId_ :: Maybe RemoteHostId
remoteHostId_ :: ChatEvent -> Maybe RemoteHostId
remoteHostId_} -> (RemoteHostId -> IO ()) -> Maybe RemoteHostId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RemoteHostId -> IO ()
removeRemoteUser Maybe RemoteHostId
remoteHostId_
      ChatEvent
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    let printEvent :: [StyledString] -> IO ()
printEvent = case Maybe String
logFilePath of
          Just String
path -> if (ChatError -> Bool)
-> (ChatEvent -> Bool) -> Either ChatError ChatEvent -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ChatError -> Bool
forall a b. a -> b -> a
const Bool
True) ChatEvent -> Bool
logEventToFile Either ChatError ChatEvent
r_ then String -> [StyledString] -> IO ()
forall {t :: * -> *}.
Foldable t =>
String -> t StyledString -> IO ()
logResponse String
path else ChatTerminal -> [StyledString] -> IO ()
printToTerminal ChatTerminal
ct
          Maybe String
_ -> ChatTerminal -> [StyledString] -> IO ()
printToTerminal ChatTerminal
ct
    Bool
liveItems <- TVar Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Bool
showLiveItems
    ChatTerminal
-> ChatController
-> Bool
-> Maybe RemoteHostId
-> Either ChatError ChatEvent
-> IO [StyledString]
forall r.
ChatResponseEvent r =>
ChatTerminal
-> ChatController
-> Bool
-> Maybe RemoteHostId
-> Either ChatError r
-> IO [StyledString]
responseString ChatTerminal
ct ChatController
cc Bool
liveItems Maybe RemoteHostId
outputRH Either ChatError ChatEvent
r_ IO [StyledString] -> ([StyledString] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [StyledString] -> IO ()
printEvent
    (ChatEvent -> IO ()) -> Either ChatError ChatEvent -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ChatTerminal -> ChatController -> ChatEvent -> IO ()
chatEventNotification ChatTerminal
ct ChatController
cc) Either ChatError ChatEvent
r_
  where
    markChatItemRead :: User -> AChatItem -> IO ()
markChatItemRead User
u (AChatItem SChatType c
_ SMsgDirection d
_ ChatInfo c
chat ci :: ChatItem c d
ci@ChatItem {CIDirection c d
chatDir :: CIDirection c d
chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir, meta :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIMeta c d
meta = CIMeta {CIStatus d
itemStatus :: CIStatus d
itemStatus :: forall (c :: ChatType) (d :: MsgDirection).
CIMeta c d -> CIStatus d
itemStatus}}) =
      case (User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
forall (c :: ChatType) (d :: MsgDirection).
User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
chatDirNtf User
u ChatInfo c
chat CIDirection c d
chatDir (ChatItem c d -> Bool
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> Bool
isUserMention ChatItem c d
ci), CIStatus d
itemStatus) of
        (Bool
True, CIStatus d
CISRcvNew) -> do
          let itemId :: RemoteHostId
itemId = ChatItem c d -> RemoteHostId
forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> RemoteHostId
chatItemId' ChatItem c d
ci
              chatRef_ :: Maybe ChatRef
chatRef_ = ChatInfo c -> Maybe ChatRef
forall (c :: ChatType). ChatInfo c -> Maybe ChatRef
chatInfoToRef ChatInfo c
chat
          Maybe ChatRef
-> (ChatRef -> IO (Either ChatError ChatResponse)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ChatRef
chatRef_ ((ChatRef -> IO (Either ChatError ChatResponse)) -> IO ())
-> (ChatRef -> IO (Either ChatError ChatResponse)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ChatRef
chatRef -> ReaderT ChatController IO (Either ChatError ChatResponse)
-> ChatController -> IO (Either ChatError ChatResponse)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ChatCommand
-> Int -> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand' (ChatRef -> NonEmpty RemoteHostId -> ChatCommand
APIChatItemsRead ChatRef
chatRef [RemoteHostId
Item (NonEmpty RemoteHostId)
itemId]) Int
0) ChatController
cc
        (Bool, CIStatus d)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    logResponse :: String -> t StyledString -> IO ()
logResponse String
path t StyledString
s = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
AppendMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> (StyledString -> IO ()) -> t StyledString -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ())
-> (StyledString -> String) -> StyledString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StyledString -> String
unStyle) t StyledString
s
    getRemoteUser :: RemoteHostId -> IO ()
getRemoteUser RemoteHostId
rhId =
      ReaderT ChatController IO (Either ChatError ChatResponse)
-> ChatController -> IO (Either ChatError ChatResponse)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Maybe RemoteHostId
-> ByteString
-> Int
-> ReaderT ChatController IO (Either ChatError ChatResponse)
execChatCommand (RemoteHostId -> Maybe RemoteHostId
forall a. a -> Maybe a
Just RemoteHostId
rhId) ByteString
"/user" Int
0) ChatController
cc IO (Either ChatError ChatResponse)
-> (Either ChatError ChatResponse -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right CRActiveUser {User
user :: User
user :: ChatResponse -> User
user} -> ChatTerminal -> User -> RemoteHostId -> IO ()
updateRemoteUser ChatTerminal
ct User
user RemoteHostId
rhId
        Either ChatError ChatResponse
cr -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected reply while getting remote user: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either ChatError ChatResponse -> Text
forall a. Show a => a -> Text
tshow Either ChatError ChatResponse
cr
    removeRemoteUser :: RemoteHostId -> IO ()
removeRemoteUser RemoteHostId
rhId = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteHostId -> TMap RemoteHostId User -> STM ()
forall k a. Ord k => k -> TMap k a -> STM ()
TM.delete RemoteHostId
rhId (ChatTerminal -> TMap RemoteHostId User
currentRemoteUsers ChatTerminal
ct)

chatEventNotification :: ChatTerminal -> ChatController -> ChatEvent -> IO ()
chatEventNotification :: ChatTerminal -> ChatController -> ChatEvent -> IO ()
chatEventNotification t :: ChatTerminal
t@ChatTerminal {Maybe (Notification -> IO ())
sendNotification :: ChatTerminal -> Maybe (Notification -> IO ())
sendNotification :: Maybe (Notification -> IO ())
sendNotification} ChatController
cc = \case
  -- At the moment of writing received items are created one at a time
  CEvtNewChatItems User
u ((AChatItem SChatType c
_ SMsgDirection d
SMDRcv ChatInfo c
cInfo ci :: ChatItem c d
ci@ChatItem {CIDirection c d
chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir :: CIDirection c d
chatDir, content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
mc, Maybe MarkdownList
formattedText :: Maybe MarkdownList
formattedText :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> Maybe MarkdownList
formattedText}) : [AChatItem]
_) ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
forall (c :: ChatType) (d :: MsgDirection).
User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
chatDirNtf User
u ChatInfo c
cInfo CIDirection c d
chatDir (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ChatItem c d -> Bool
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> Bool
isUserMention ChatItem c d
ci) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> ChatInfo c -> IO ()
forall (c :: ChatType). ChatTerminal -> ChatInfo c -> IO ()
setActiveChat ChatTerminal
t ChatInfo c
cInfo
      case (ChatInfo c
cInfo, CIDirection c d
chatDir) of
        (DirectChat Contact
ct, CIDirection c d
_) -> (Text, Text) -> IO ()
sendNtf (Contact -> Text
viewContactName Contact
ct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"> ", Text
text)
        (GroupChat GroupInfo
g Maybe GroupChatScopeInfo
scopeInfo, CIGroupRcv GroupMember
m) -> (Text, Text) -> IO ()
sendNtf (GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Text
fromGroup_ GroupInfo
g Maybe GroupChatScopeInfo
scopeInfo GroupMember
m, Text
text)
        (ChatInfo c, CIDirection c d)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    where
      text :: Text
text = MsgContent -> Maybe MarkdownList -> Text
msgText MsgContent
mc Maybe MarkdownList
formattedText
  CEvtChatItemUpdated User
u (AChatItem SChatType c
_ SMsgDirection d
SMDRcv ChatInfo c
cInfo ci :: ChatItem c d
ci@ChatItem {CIDirection c d
chatDir :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIDirection c d
chatDir :: CIDirection c d
chatDir, content :: forall (c :: ChatType) (d :: MsgDirection).
ChatItem c d -> CIContent d
content = CIRcvMsgContent MsgContent
_}) ->
    ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
forall (c :: ChatType) (d :: MsgDirection).
User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
chatDirNtf User
u ChatInfo c
cInfo CIDirection c d
chatDir (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ChatItem c d -> Bool
forall (c :: ChatType) (d :: MsgDirection). ChatItem c d -> Bool
isUserMention ChatItem c d
ci) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> ChatInfo c -> IO ()
forall (c :: ChatType). ChatTerminal -> ChatInfo c -> IO ()
setActiveChat ChatTerminal
t ChatInfo c
cInfo
  CEvtContactConnected User
u Contact
ct Maybe Profile
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> Contact -> Bool -> Bool
contactNtf User
u Contact
ct Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> Contact -> IO ()
setActiveContact ChatTerminal
t Contact
ct
    (Text, Text) -> IO ()
sendNtf (Contact -> Text
viewContactName Contact
ct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"> ", Text
"connected")
  CEvtContactSndReady User
u Contact
ct ->
    ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> Contact -> IO ()
setActiveContact ChatTerminal
t Contact
ct
  CEvtContactAnotherClient User
u Contact
ct -> do
    ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> Contact -> IO ()
unsetActiveContact ChatTerminal
t Contact
ct
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> Contact -> Bool -> Bool
contactNtf User
u Contact
ct Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> IO ()
sendNtf (Contact -> Text
viewContactName Contact
ct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"> ", Text
"connected to another client")
  CEvtReceivedGroupInvitation User
u GroupInfo
g Contact
ct GroupMemberRole
_ GroupMemberRole
_ ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> Contact -> Bool -> Bool
contactNtf User
u Contact
ct Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      (Text, Text) -> IO ()
sendNtf (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
viewGroupName GroupInfo
g Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Contact -> Text
viewContactName Contact
ct Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"> ", Text
"invited you to join the group")
  CEvtUserJoinedGroup User
u GroupInfo
g GroupMember
_ -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> GroupInfo -> Bool -> Bool
groupNtf User
u GroupInfo
g Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> GroupInfo -> IO ()
setActiveGroup ChatTerminal
t GroupInfo
g
    (Text, Text) -> IO ()
sendNtf (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
viewGroupName GroupInfo
g, Text
"you are connected to group")
  CEvtJoinedGroupMember User
u GroupInfo
g GroupMember
m ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> GroupInfo -> Bool -> Bool
groupNtf User
u GroupInfo
g Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> IO ()
sendNtf (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
viewGroupName GroupInfo
g, Text
"member " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupMember -> Text
viewMemberName GroupMember
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is connected")
  CEvtJoinedGroupMemberConnecting User
u GroupInfo
g GroupMember
_ GroupMember
m | GroupMember -> GroupMemberStatus
memberStatus GroupMember
m GroupMemberStatus -> GroupMemberStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GroupMemberStatus
GSMemPendingReview ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> GroupInfo -> Bool -> Bool
groupNtf User
u GroupInfo
g Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> IO ()
sendNtf (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
viewGroupName GroupInfo
g, Text
"member " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupMember -> Text
viewMemberName GroupMember
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is pending review")
  CEvtConnectedToGroupMember User
u GroupInfo
g GroupMember
m Maybe Contact
_ ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> GroupInfo -> Bool -> Bool
groupNtf User
u GroupInfo
g Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> IO ()
sendNtf (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
viewGroupName GroupInfo
g, Text
"member " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupMember -> Text
viewMemberName GroupMember
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is connected")
  CEvtReceivedContactRequest User
u UserContactRequest {localDisplayName :: UserContactRequest -> Text
localDisplayName = Text
n} Maybe AChat
_ ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> Bool
userNtf User
u) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> IO ()
sendNtf (Text -> Text
viewName Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">", Text
"wants to connect to you")
  ChatEvent
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    sendNtf :: (Text, Text) -> IO ()
sendNtf = ((Text, Text) -> IO ())
-> ((Notification -> IO ()) -> (Text, Text) -> IO ())
-> Maybe (Notification -> IO ())
-> (Text, Text)
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (\(Text, Text)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Notification -> IO ())
-> ((Text, Text) -> Notification) -> (Text, Text) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Notification) -> (Text, Text) -> Notification
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Notification
Notification) Maybe (Notification -> IO ())
sendNotification

msgText :: MsgContent -> Maybe MarkdownList -> Text
msgText :: MsgContent -> Maybe MarkdownList -> Text
msgText (MCFile Text
_) Maybe MarkdownList
_ = Text
"wants to send a file"
msgText MsgContent
mc Maybe MarkdownList
md_ = Text -> (MarkdownList -> Text) -> Maybe MarkdownList -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MsgContent -> Text
msgContentText MsgContent
mc) ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text)
-> (MarkdownList -> [Text]) -> MarkdownList -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormattedText -> Text) -> MarkdownList -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FormattedText -> Text
hideSecret) Maybe MarkdownList
md_
  where
    hideSecret :: FormattedText -> Text
    hideSecret :: FormattedText -> Text
hideSecret FormattedText {format :: FormattedText -> Maybe Format
format = Just Format
Secret} = Text
"..."
    hideSecret FormattedText {Text
text :: Text
text :: FormattedText -> Text
text} = Text
text

chatActiveTo :: ChatName -> String
chatActiveTo :: ChatName -> String
chatActiveTo (ChatName ChatType
cType Text
name) = case ChatType
cType of
  ChatType
CTDirect -> Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
viewName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
  ChatType
CTGroup -> Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
viewName Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "
  ChatType
_ -> String
""

chatInfoActiveTo :: ChatInfo c -> String
chatInfoActiveTo :: forall (c :: ChatType). ChatInfo c -> String
chatInfoActiveTo = \case
  DirectChat Contact
c -> Contact -> String
contactActiveTo Contact
c
  GroupChat GroupInfo
g Maybe GroupChatScopeInfo
_scopeInfo -> GroupInfo -> String
groupActiveTo GroupInfo
g
  ChatInfo c
_ -> String
""

contactActiveTo :: Contact -> String
contactActiveTo :: Contact -> String
contactActiveTo Contact
c = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Contact -> Text
viewContactName Contact
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "

groupActiveTo :: GroupInfo -> String
groupActiveTo :: GroupInfo -> String
groupActiveTo GroupInfo
g = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GroupInfo -> Text
viewGroupName GroupInfo
g Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" "

setActiveChat :: ChatTerminal -> ChatInfo c -> IO ()
setActiveChat :: forall (c :: ChatType). ChatTerminal -> ChatInfo c -> IO ()
setActiveChat ChatTerminal
t = ChatTerminal -> String -> IO ()
setActive ChatTerminal
t (String -> IO ()) -> (ChatInfo c -> String) -> ChatInfo c -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChatInfo c -> String
forall (c :: ChatType). ChatInfo c -> String
chatInfoActiveTo

setActiveContact :: ChatTerminal -> Contact -> IO ()
setActiveContact :: ChatTerminal -> Contact -> IO ()
setActiveContact ChatTerminal
t = ChatTerminal -> String -> IO ()
setActive ChatTerminal
t (String -> IO ()) -> (Contact -> String) -> Contact -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contact -> String
contactActiveTo

setActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
setActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
setActiveGroup ChatTerminal
t = ChatTerminal -> String -> IO ()
setActive ChatTerminal
t (String -> IO ()) -> (GroupInfo -> String) -> GroupInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupInfo -> String
groupActiveTo

setActive :: ChatTerminal -> String -> IO ()
setActive :: ChatTerminal -> String -> IO ()
setActive ChatTerminal {TVar String
activeTo :: ChatTerminal -> TVar String
activeTo :: TVar String
activeTo} String
to = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar String -> String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar String
activeTo String
to

unsetActiveContact :: ChatTerminal -> Contact -> IO ()
unsetActiveContact :: ChatTerminal -> Contact -> IO ()
unsetActiveContact ChatTerminal
t = ChatTerminal -> String -> IO ()
unsetActive ChatTerminal
t (String -> IO ()) -> (Contact -> String) -> Contact -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contact -> String
contactActiveTo

unsetActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
unsetActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
unsetActiveGroup ChatTerminal
t = ChatTerminal -> String -> IO ()
unsetActive ChatTerminal
t (String -> IO ()) -> (GroupInfo -> String) -> GroupInfo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupInfo -> String
groupActiveTo

unsetActive :: ChatTerminal -> String -> IO ()
unsetActive :: ChatTerminal -> String -> IO ()
unsetActive ChatTerminal {TVar String
activeTo :: ChatTerminal -> TVar String
activeTo :: TVar String
activeTo} String
to' = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar String -> (String -> String) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar String
activeTo String -> String
unset
  where
    unset :: String -> String
unset String
to = if String
to String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
to' then String
"" else String
to

whenCurrUser :: ChatController -> User -> IO () -> IO ()
whenCurrUser :: ChatController -> User -> IO () -> IO ()
whenCurrUser ChatController
cc User
u IO ()
a = do
  Maybe User
u_ <- TVar (Maybe User) -> IO (Maybe User)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (TVar (Maybe User) -> IO (Maybe User))
-> TVar (Maybe User) -> IO (Maybe User)
forall a b. (a -> b) -> a -> b
$ ChatController -> TVar (Maybe User)
currentUser ChatController
cc
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (User -> Maybe User -> Bool
sameUser User
u Maybe User
u_) IO ()
a
  where
    sameUser :: User -> Maybe User -> Bool
sameUser User {userId :: User -> RemoteHostId
userId = RemoteHostId
uId} = Bool -> (User -> Bool) -> Maybe User -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((User -> Bool) -> Maybe User -> Bool)
-> (User -> Bool) -> Maybe User -> Bool
forall a b. (a -> b) -> a -> b
$ \User {RemoteHostId
userId :: User -> RemoteHostId
userId :: RemoteHostId
userId} -> RemoteHostId
userId RemoteHostId -> RemoteHostId -> Bool
forall a. Eq a => a -> a -> Bool
== RemoteHostId
uId

printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> Either ChatError ChatResponse -> IO ()
printRespToTerminal :: ChatTerminal
-> ChatController
-> Bool
-> Maybe RemoteHostId
-> Either ChatError ChatResponse
-> IO ()
printRespToTerminal ChatTerminal
ct ChatController
cc Bool
liveItems Maybe RemoteHostId
outputRH Either ChatError ChatResponse
r = ChatTerminal
-> ChatController
-> Bool
-> Maybe RemoteHostId
-> Either ChatError ChatResponse
-> IO [StyledString]
forall r.
ChatResponseEvent r =>
ChatTerminal
-> ChatController
-> Bool
-> Maybe RemoteHostId
-> Either ChatError r
-> IO [StyledString]
responseString ChatTerminal
ct ChatController
cc Bool
liveItems Maybe RemoteHostId
outputRH Either ChatError ChatResponse
r IO [StyledString] -> ([StyledString] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChatTerminal -> [StyledString] -> IO ()
printToTerminal ChatTerminal
ct

responseString :: forall r. ChatResponseEvent r => ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> Either ChatError r -> IO [StyledString]
responseString :: forall r.
ChatResponseEvent r =>
ChatTerminal
-> ChatController
-> Bool
-> Maybe RemoteHostId
-> Either ChatError r
-> IO [StyledString]
responseString ChatTerminal
ct ChatController
cc Bool
liveItems Maybe RemoteHostId
outputRH = \case
  Right r
r -> do
    (Maybe RemoteHostId, Maybe User)
cu <- ChatTerminal
-> ChatController -> IO (Maybe RemoteHostId, Maybe User)
getCurrentUser ChatTerminal
ct ChatController
cc
    UTCTime
ts <- IO UTCTime
getCurrentTime
    TimeZone
tz <- IO TimeZone
getCurrentTimeZone
    [StyledString] -> IO [StyledString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StyledString] -> IO [StyledString])
-> [StyledString] -> IO [StyledString]
forall a b. (a -> b) -> a -> b
$ (Maybe RemoteHostId, Maybe User)
-> ChatConfig
-> Bool
-> UTCTime
-> TimeZone
-> Maybe RemoteHostId
-> r
-> [StyledString]
forall r.
ChatResponseEvent r =>
(Maybe RemoteHostId, Maybe User)
-> ChatConfig
-> Bool
-> UTCTime
-> TimeZone
-> Maybe RemoteHostId
-> r
-> [StyledString]
responseToView (Maybe RemoteHostId, Maybe User)
cu (ChatController -> ChatConfig
config ChatController
cc) Bool
liveItems UTCTime
ts TimeZone
tz Maybe RemoteHostId
outputRH r
r
  Left ChatError
e -> [StyledString] -> IO [StyledString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StyledString] -> IO [StyledString])
-> [StyledString] -> IO [StyledString]
forall a b. (a -> b) -> a -> b
$ Bool -> ChatConfig -> ChatError -> [StyledString]
chatErrorToView (forall r. ChatResponseEvent r => Bool
isCommandResponse @r) (ChatController -> ChatConfig
config ChatController
cc) ChatError
e

updateRemoteUser :: ChatTerminal -> User -> RemoteHostId -> IO ()
updateRemoteUser :: ChatTerminal -> User -> RemoteHostId -> IO ()
updateRemoteUser ChatTerminal
ct User
user RemoteHostId
rhId = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteHostId -> User -> TMap RemoteHostId User -> STM ()
forall k a. Ord k => k -> a -> TMap k a -> STM ()
TM.insert RemoteHostId
rhId User
user (ChatTerminal -> TMap RemoteHostId User
currentRemoteUsers ChatTerminal
ct)

getCurrentUser :: ChatTerminal -> ChatController -> IO (Maybe RemoteHostId, Maybe User)
getCurrentUser :: ChatTerminal
-> ChatController -> IO (Maybe RemoteHostId, Maybe User)
getCurrentUser ChatTerminal
ct ChatController
cc = STM (Maybe RemoteHostId, Maybe User)
-> IO (Maybe RemoteHostId, Maybe User)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RemoteHostId, Maybe User)
 -> IO (Maybe RemoteHostId, Maybe User))
-> STM (Maybe RemoteHostId, Maybe User)
-> IO (Maybe RemoteHostId, Maybe User)
forall a b. (a -> b) -> a -> b
$ do
  Maybe User
localUser_ <- TVar (Maybe User) -> STM (Maybe User)
forall a. TVar a -> STM a
readTVar (ChatController -> TVar (Maybe User)
currentUser ChatController
cc)
  TVar (Maybe RemoteHostId) -> STM (Maybe RemoteHostId)
forall a. TVar a -> STM a
readTVar (ChatController -> TVar (Maybe RemoteHostId)
currentRemoteHost ChatController
cc) STM (Maybe RemoteHostId)
-> (Maybe RemoteHostId -> STM (Maybe RemoteHostId, Maybe User))
-> STM (Maybe RemoteHostId, Maybe User)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RemoteHostId
Nothing -> (Maybe RemoteHostId, Maybe User)
-> STM (Maybe RemoteHostId, Maybe User)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RemoteHostId
forall a. Maybe a
Nothing, Maybe User
localUser_)
    Just RemoteHostId
rhId ->
      RHKey
-> TMap RHKey (Int, RemoteHostSession)
-> STM (Maybe (Int, RemoteHostSession))
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup (RemoteHostId -> RHKey
RHId RemoteHostId
rhId) (ChatController -> TMap RHKey (Int, RemoteHostSession)
remoteHostSessions ChatController
cc) STM (Maybe (Int, RemoteHostSession))
-> (Maybe (Int, RemoteHostSession)
    -> STM (Maybe RemoteHostId, Maybe User))
-> STM (Maybe RemoteHostId, Maybe User)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Int
_, RHSessionConnected {}) -> do
          Maybe User
hostUser_ <- RemoteHostId -> TMap RemoteHostId User -> STM (Maybe User)
forall k a. Ord k => k -> TMap k a -> STM (Maybe a)
TM.lookup RemoteHostId
rhId (ChatTerminal -> TMap RemoteHostId User
currentRemoteUsers ChatTerminal
ct)
          (Maybe RemoteHostId, Maybe User)
-> STM (Maybe RemoteHostId, Maybe User)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RemoteHostId -> Maybe RemoteHostId
forall a. a -> Maybe a
Just RemoteHostId
rhId, Maybe User
hostUser_)
        Maybe (Int, RemoteHostSession)
_ -> (Maybe RemoteHostId, Maybe User)
-> STM (Maybe RemoteHostId, Maybe User)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RemoteHostId
forall a. Maybe a
Nothing, Maybe User
localUser_)

printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ChatTerminal
ct [StyledString]
s =
  ChatTerminal
-> (forall {t}. WithTerminal t => TerminalT t IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ChatTerminal
-> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal
ct ((forall {t}. WithTerminal t => TerminalT t IO ()) -> IO ())
-> (forall {t}. WithTerminal t => TerminalT t IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    ChatTerminal -> TerminalT t IO () -> TerminalT t IO ()
forall (m :: * -> *).
MonadTerminal m =>
ChatTerminal -> m () -> m ()
withTermLock ChatTerminal
ct (TerminalT t IO () -> TerminalT t IO ())
-> TerminalT t IO () -> TerminalT t IO ()
forall a b. (a -> b) -> a -> b
$ do
      ChatTerminal -> [StyledString] -> TerminalT t IO ()
forall (m :: * -> *).
MonadTerminal m =>
ChatTerminal -> [StyledString] -> m ()
printMessage ChatTerminal
ct [StyledString]
s
      ChatTerminal -> TerminalT t IO ()
forall (m :: * -> *). MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal
ct

updateInputView :: ChatTerminal -> IO ()
updateInputView :: ChatTerminal -> IO ()
updateInputView ChatTerminal
ct = ChatTerminal
-> (forall {t}. WithTerminal t => TerminalT t IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ChatTerminal
-> (forall t. WithTerminal t => TerminalT t m a) -> m a
withChatTerm ChatTerminal
ct ((forall {t}. WithTerminal t => TerminalT t IO ()) -> IO ())
-> (forall {t}. WithTerminal t => TerminalT t IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> TerminalT t IO () -> TerminalT t IO ()
forall (m :: * -> *).
MonadTerminal m =>
ChatTerminal -> m () -> m ()
withTermLock ChatTerminal
ct (TerminalT t IO () -> TerminalT t IO ())
-> TerminalT t IO () -> TerminalT t IO ()
forall a b. (a -> b) -> a -> b
$ ChatTerminal -> TerminalT t IO ()
forall (m :: * -> *). MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal
ct

updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
updateInput :: forall (m :: * -> *). MonadTerminal m => ChatTerminal -> m ()
updateInput ChatTerminal {termSize :: ChatTerminal -> Size
termSize = Size {Int
height :: Size -> Int
height :: Int
height, Int
width :: Int
width :: Size -> Int
width}, TVar TerminalState
termState :: ChatTerminal -> TVar TerminalState
termState :: TVar TerminalState
termState, TVar Int
nextMessageRow :: ChatTerminal -> TVar Int
nextMessageRow :: TVar Int
nextMessageRow} = do
  m ()
forall (m :: * -> *). MonadScreen m => m ()
hideCursor
  TerminalState
ts <- TVar TerminalState -> m TerminalState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar TerminalState
termState
  Int
nmr <- TVar Int -> m Int
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int
nextMessageRow
  let ih :: Int
ih = TerminalState -> Int
inputHeight TerminalState
ts
      iStart :: Int
iStart = Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ih
      prompt :: String
prompt = TerminalState -> String
inputPrompt TerminalState
ts
      acPfx :: String
acPfx = TerminalState -> String
autoCompletePrefix TerminalState
ts
      Position {Int
row :: Int
row :: Position -> Int
row, Int
col :: Int
col :: Position -> Int
col} = Int -> Int -> Position
positionRowColumn Int
width (Int -> Position) -> Int -> Position
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
acPfx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prompt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TerminalState -> Int
inputPosition TerminalState
ts
  if Int
nmr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
iStart
    then STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
nextMessageRow Int
iStart
    else Int -> Int -> m ()
clearLines Int
nmr Int
iStart
  Position -> m ()
forall (m :: * -> *). MonadScreen m => Position -> m ()
setCursorPosition (Position -> m ()) -> Position -> m ()
forall a b. (a -> b) -> a -> b
$ Position {row :: Int
row = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
nmr Int
iStart, col :: Int
col = Int
0}
  StyledString -> m ()
forall (m :: * -> *). MonadTerminal m => StyledString -> m ()
putStyled (StyledString -> m ()) -> StyledString -> m ()
forall a b. (a -> b) -> a -> b
$ [SGR] -> String -> StyledString
Styled [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
White] String
acPfx
  String -> m ()
forall (m :: * -> *). MonadPrinter m => String -> m ()
putString (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
prompt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TerminalState -> String
inputString TerminalState
ts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "
  EraseMode -> m ()
forall (m :: * -> *). MonadScreen m => EraseMode -> m ()
eraseInLine EraseMode
EraseForward
  Position -> m ()
forall (m :: * -> *). MonadScreen m => Position -> m ()
setCursorPosition (Position -> m ()) -> Position -> m ()
forall a b. (a -> b) -> a -> b
$ Position {row :: Int
row = Int
iStart Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
row, Int
col :: Int
col :: Int
col}
  m ()
forall (m :: * -> *). MonadScreen m => m ()
showCursor
  m ()
forall (m :: * -> *). MonadPrinter m => m ()
flush
  where
    clearLines :: Int -> Int -> m ()
    clearLines :: Int -> Int -> m ()
clearLines Int
from Int
till
      | Int
from Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
till = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = do
          Position -> m ()
forall (m :: * -> *). MonadScreen m => Position -> m ()
setCursorPosition (Position -> m ()) -> Position -> m ()
forall a b. (a -> b) -> a -> b
$ Position {row :: Int
row = Int
from, col :: Int
col = Int
0}
          EraseMode -> m ()
forall (m :: * -> *). MonadScreen m => EraseMode -> m ()
eraseInLine EraseMode
EraseForward
          Int -> Int -> m ()
clearLines (Int
from Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
till
    inputHeight :: TerminalState -> Int
    inputHeight :: TerminalState -> Int
inputHeight TerminalState
ts = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TerminalState -> String
autoCompletePrefix TerminalState
ts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TerminalState -> String
inputPrompt TerminalState
ts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TerminalState -> String
inputString TerminalState
ts) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    autoCompletePrefix :: TerminalState -> String
    autoCompletePrefix :: TerminalState -> String
autoCompletePrefix TerminalState {autoComplete :: TerminalState -> AutoCompleteState
autoComplete = AutoCompleteState
ac}
      | [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
vars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 Bool -> Bool -> Bool
|| ACShowVariants
sv ACShowVariants -> ACShowVariants -> Bool
forall a. Eq a => a -> a -> Bool
== ACShowVariants
SVNone = String
""
      | ACShowVariants
sv ACShowVariants -> ACShowVariants -> Bool
forall a. Eq a => a -> a -> Bool
== ACShowVariants
SVAll Bool -> Bool -> Bool
|| [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
vars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
4 = String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
vars String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") "
      | Bool
otherwise = String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
3 [String]
vars) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"... +" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
vars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") "
      where
        sv :: ACShowVariants
sv = AutoCompleteState -> ACShowVariants
acShowVariants AutoCompleteState
ac
        vars :: [String]
vars = AutoCompleteState -> [String]
acVariants AutoCompleteState
ac
    positionRowColumn :: Int -> Int -> Position
    positionRowColumn :: Int -> Int -> Position
positionRowColumn Int
wid Int
pos =
      let row :: Int
row = Int
pos Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
wid
          col :: Int
col = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
row Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
wid
       in Position {Int
row :: Int
row :: Int
row, Int
col :: Int
col :: Int
col}

printMessage :: forall m. MonadTerminal m => ChatTerminal -> [StyledString] -> m ()
printMessage :: forall (m :: * -> *).
MonadTerminal m =>
ChatTerminal -> [StyledString] -> m ()
printMessage ChatTerminal {termSize :: ChatTerminal -> Size
termSize = Size {Int
height :: Size -> Int
height :: Int
height, Int
width :: Size -> Int
width :: Int
width}, TVar Int
nextMessageRow :: ChatTerminal -> TVar Int
nextMessageRow :: TVar Int
nextMessageRow} [StyledString]
msg = do
  Int
nmr <- TVar Int -> m Int
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar Int
nextMessageRow
  Position -> m ()
forall (m :: * -> *). MonadScreen m => Position -> m ()
setCursorPosition (Position -> m ()) -> Position -> m ()
forall a b. (a -> b) -> a -> b
$ Position {row :: Int
row = Int
nmr, col :: Int
col = Int
0}
  (StyledString -> m ()) -> [StyledString] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ StyledString -> m ()
printStyled [StyledString]
msg
  m ()
forall (m :: * -> *). MonadPrinter m => m ()
flush
  let lc :: Int
lc = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (StyledString -> Int) -> [StyledString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map StyledString -> Int
lineCount [StyledString]
msg
  STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> (Int -> STM ()) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
nextMessageRow (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
nmr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lc)
  where
    lineCount :: StyledString -> Int
    lineCount :: StyledString -> Int
lineCount StyledString
s = StyledString -> Int
sLength StyledString
s Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    printStyled :: StyledString -> m ()
    printStyled :: StyledString -> m ()
printStyled StyledString
s = do
      StyledString -> m ()
forall (m :: * -> *). MonadTerminal m => StyledString -> m ()
putStyled StyledString
s
      EraseMode -> m ()
forall (m :: * -> *). MonadScreen m => EraseMode -> m ()
eraseInLine EraseMode
EraseForward
      m ()
forall (m :: * -> *). MonadPrinter m => m ()
putLn

-- Currently it is assumed that the message does not have internal line breaks.
-- Previous implementation "kind of" supported them,
-- but it was not determining the number of printed lines correctly
-- because of accounting for control sequences in length
putStyled :: MonadTerminal m => StyledString -> m ()
putStyled :: forall (m :: * -> *). MonadTerminal m => StyledString -> m ()
putStyled (StyledString
s1 :<>: StyledString
s2) = StyledString -> m ()
forall (m :: * -> *). MonadTerminal m => StyledString -> m ()
putStyled StyledString
s1 m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StyledString -> m ()
forall (m :: * -> *). MonadTerminal m => StyledString -> m ()
putStyled StyledString
s2
putStyled (Styled [] String
s) = String -> m ()
forall (m :: * -> *). MonadPrinter m => String -> m ()
putString String
s
putStyled (Styled [SGR]
sgr String
s) = [SGR] -> m ()
forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR [SGR]
sgr m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> m ()
forall (m :: * -> *). MonadPrinter m => String -> m ()
putString String
s m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). MonadMarkupPrinter m => m ()
resetAttributes

setSGR :: MonadTerminal m => [SGR] -> m ()
setSGR :: forall (m :: * -> *). MonadTerminal m => [SGR] -> m ()
setSGR = (SGR -> m ()) -> [SGR] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SGR -> m ()) -> [SGR] -> m ()) -> (SGR -> m ()) -> [SGR] -> m ()
forall a b. (a -> b) -> a -> b
$ \case
  SGR
Reset -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => m ()
resetAttributes
  SetConsoleIntensity ConsoleIntensity
BoldIntensity -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
bold
  SetConsoleIntensity ConsoleIntensity
_ -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
resetAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
bold
  SetItalicized Bool
True -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
italic
  SetItalicized Bool
_ -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
resetAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
italic
  SetUnderlining Underlining
NoUnderline -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
resetAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
underlined
  SetUnderlining Underlining
_ -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
underlined
  SetSwapForegroundBackground Bool
True -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
inverted
  SetSwapForegroundBackground Bool
_ -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
resetAttribute Attribute m
forall (m :: * -> *). MonadFormattingPrinter m => Attribute m
inverted
  SetColor ConsoleLayer
l ColorIntensity
i Color
c -> Attribute m -> m ()
forall (m :: * -> *). MonadMarkupPrinter m => Attribute m -> m ()
setAttribute (Attribute m -> m ())
-> (Color m -> Attribute m) -> Color m -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleLayer -> Color m -> Attribute m
layer ConsoleLayer
l (Color m -> Attribute m)
-> (Color m -> Color m) -> Color m -> Attribute m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColorIntensity -> Color m -> Color m
intensity ColorIntensity
i (Color m -> m ()) -> Color m -> m ()
forall a b. (a -> b) -> a -> b
$ Color -> Color m
color Color
c
  SetBlinkSpeed BlinkSpeed
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SetVisible Bool
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SetRGBColor ConsoleLayer
_ Colour Float
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SetPaletteColor ConsoleLayer
_ Word8
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SetDefaultColor ConsoleLayer
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    layer :: ConsoleLayer -> Color m -> Attribute m
layer = \case
      ConsoleLayer
Foreground -> Color m -> Attribute m
forall (m :: * -> *). MonadColorPrinter m => Color m -> Attribute m
foreground
      ConsoleLayer
Background -> Color m -> Attribute m
forall (m :: * -> *). MonadColorPrinter m => Color m -> Attribute m
background
    intensity :: ColorIntensity -> Color m -> Color m
intensity = \case
      ColorIntensity
Dull -> Color m -> Color m
forall a. a -> a
id
      ColorIntensity
Vivid -> Color m -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m -> Color m
bright
    color :: Color -> Color m
color = \case
      Color
Black -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
black
      Color
Red -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
red
      Color
Green -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
green
      Color
Yellow -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
yellow
      Color
Blue -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
blue
      Color
Magenta -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
magenta
      Color
Cyan -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
cyan
      Color
White -> Color m
forall (m :: * -> *). MonadColorPrinter m => Color m
white