chat test with VirtualTerminal (#72)

* chat test with VirtualTerminal

* disable chat test

* fix intermittently failing test

* simplify test

src/Simplex/Chat/Controller.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Chat.Controller where
@@ -11,7 +10,6 @@ import Control.Exception
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Numeric.Natural
 import Simplex.Chat.Notification
 import Simplex.Chat.Store (StoreError)
 import Simplex.Chat.Terminal
@@ -45,13 +43,6 @@ data ContactError = CENotFound ContactRef | CEProfile String
 
 type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
 
-newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> User -> (Notification -> IO ()) -> Natural -> STM ChatController
-newChatController smpAgent chatTerminal chatStore currentUser sendNotification qSize = do
-  inputQ <- newTBQueue qSize
-  notifyQ <- newTBQueue qSize
-  -- chatQ <- newTBQueue qSize
-  pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, inputQ, notifyQ, sendNotification}
-
 setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
 setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)
 

src/Simplex/Chat/Input.hs

@@ -24,9 +24,10 @@ getKey =
 runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 runTerminalInput = do
   ChatController {inputQ, chatTerminal = ct} <- ask
-  liftIO . withTerminal . runTerminalT $ do
-    updateInput ct
-    receiveFromTTY inputQ ct
+  liftIO $
+    withChatTerm ct $ do
+      updateInput ct
+      receiveFromTTY inputQ ct
 
 receiveFromTTY :: MonadTerminal m => TBQueue InputEvent -> ChatTerminal -> m ()
 receiveFromTTY inputQ ct@ChatTerminal {activeTo, termSize, termState} =

src/Simplex/Chat/Terminal.hs

@@ -1,13 +1,18 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Chat.Terminal where
 
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.IO.Class (MonadIO)
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
 import System.Console.ANSI.Types
 import System.Terminal
+import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
 import UnliftIO.STM
 
 data ActiveTo = ActiveNone | ActiveC ContactRef
@@ -15,6 +20,7 @@ data ActiveTo = ActiveNone | ActiveC ContactRef
 
 data ChatTerminal = ChatTerminal
   { activeTo :: TVar ActiveTo,
+    termDevice :: TerminalDevice,
     termState :: TVar TerminalState,
     termSize :: Size,
     nextMessageRow :: TVar Int,
@@ -28,16 +34,30 @@ data TerminalState = TerminalState
     previousInput :: String
   }
 
-newChatTerminal :: IO ChatTerminal
-newChatTerminal = do
+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 _ = withTerminal
+
+instance WithTerminal VirtualTerminal where
+  withTerm t = ($ t)
+
+withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
+withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
+
+newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
+newChatTerminal t = do
   activeTo <- newTVarIO ActiveNone
-  termSize <- withTerminal . runTerminalT $ getWindowSize
+  termSize <- withTerm t . runTerminalT $ getWindowSize
   let lastRow = height termSize - 1
   termState <- newTVarIO newTermState
   termLock <- newTMVarIO ()
   nextMessageRow <- newTVarIO lastRow
   -- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
-  return ChatTerminal {activeTo, termState, termSize, nextMessageRow, termLock}
+  return ChatTerminal {activeTo, termDevice = TerminalDevice t, termState, termSize, nextMessageRow, termLock}
 
 newTermState :: TerminalState
 newTermState =
@@ -55,9 +75,11 @@ withTermLock ChatTerminal {termLock} action = do
   atomically $ putTMVar termLock ()
 
 printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
-printToTerminal ct s = withTerminal . runTerminalT . withTermLock ct $ do
-  printMessage ct s
-  updateInput ct
+printToTerminal ct s =
+  withChatTerm ct $
+    withTermLock ct $ do
+      printMessage ct s
+      updateInput ct
 
 updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
 updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do

src/Simplex/Chat/View.hs

@@ -133,7 +133,7 @@ ttyContact :: ContactRef -> StyledString
 ttyContact = styled (Colored Green)
 
 ttyToContact :: ContactRef -> StyledString
-ttyToContact c = styled (Colored Cyan) $ c <> " "
+ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
 
 ttyFromContact :: ContactRef -> StyledString
 ttyFromContact c = styled (Colored Yellow) $ c <> "> "