module Matterhorn.App
( runMatterhorn
, closeMatterhorn
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick
import Control.Monad.Trans.Except ( runExceptT )
import qualified Data.HashMap.Strict as HM
import qualified Graphics.Vty as Vty
import Text.Aspell ( stopAspell )
import GHC.Conc (getNumProcessors, setNumCapabilities)
import System.Posix.IO ( stdInput )
import Network.Mattermost
import Matterhorn.Config
import Matterhorn.Draw
import qualified Matterhorn.Events as Events
import Matterhorn.IOUtil
import Matterhorn.InputHistory
import Matterhorn.LastRunState
import Matterhorn.Options hiding ( ShowHelp )
import Matterhorn.State.Setup
import Matterhorn.State.Setup.Threads.Logging ( shutdownLogManager )
import Matterhorn.Types
app :: App ChatState MHEvent Name
app :: App ChatState MHEvent Name
app = App :: forall s e n.
(s -> [Widget n])
-> (s -> [CursorLocation n] -> Maybe (CursorLocation n))
-> (s -> BrickEvent n e -> EventM n (Next s))
-> (s -> EventM n s)
-> (s -> AttrMap)
-> App s e n
App
{ appDraw :: ChatState -> [Widget Name]
appDraw = ChatState -> [Widget Name]
draw
, appChooseCursor :: ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appChooseCursor = \ChatState
s [CursorLocation Name]
cs -> case ChatState
sChatState -> Getting Mode ChatState Mode -> Mode
forall s a. s -> Getting a s a -> a
^.(TeamState -> Const Mode TeamState)
-> ChatState -> Const Mode ChatState
Lens' ChatState TeamState
csCurrentTeam((TeamState -> Const Mode TeamState)
-> ChatState -> Const Mode ChatState)
-> ((Mode -> Const Mode Mode) -> TeamState -> Const Mode TeamState)
-> Getting Mode ChatState Mode
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Mode -> Const Mode Mode) -> TeamState -> Const Mode TeamState
Lens' TeamState Mode
tsMode of
Mode
Main -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
ChannelSelect -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
UserListOverlay -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
ReactionEmojiListOverlay -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
ChannelListOverlay -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
ManageAttachmentsBrowseFiles -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
ThemeListOverlay -> ChatState -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor ChatState
s [CursorLocation Name]
cs
Mode
ChannelTopicWindow -> let tId :: TeamId
tId = ChatState
sChatState -> Getting TeamId ChatState TeamId -> TeamId
forall s a. s -> Getting a s a -> a
^.Getting TeamId ChatState TeamId
SimpleGetter ChatState TeamId
csCurrentTeamId
in Name -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall n.
Eq n =>
n -> [CursorLocation n] -> Maybe (CursorLocation n)
showCursorNamed (TeamId -> Name
ChannelTopicEditor TeamId
tId) [CursorLocation Name]
cs
SaveAttachmentWindow LinkChoice
_ -> let tId :: TeamId
tId = ChatState
sChatState -> Getting TeamId ChatState TeamId -> TeamId
forall s a. s -> Getting a s a -> a
^.Getting TeamId ChatState TeamId
SimpleGetter ChatState TeamId
csCurrentTeamId
in Name -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall n.
Eq n =>
n -> [CursorLocation n] -> Maybe (CursorLocation n)
showCursorNamed (TeamId -> Name
AttachmentPathEditor TeamId
tId) [CursorLocation Name]
cs
Mode
LeaveChannelConfirm -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
DeleteChannelConfirm -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
MessageSelect -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
MessageSelectDeleteConfirm -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
PostListOverlay PostListContents
_ -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
ManageAttachments -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
ViewMessage -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
ShowHelp HelpTopic
_ Mode
_ -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
UrlSelect -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
Mode
EditNotifyPrefs -> Maybe (CursorLocation Name)
forall a. Maybe a
Nothing
, appHandleEvent :: ChatState
-> BrickEvent Name MHEvent -> EventM Name (Next ChatState)
appHandleEvent = ChatState
-> BrickEvent Name MHEvent -> EventM Name (Next ChatState)
Events.onEvent
, appStartEvent :: ChatState -> EventM Name ChatState
appStartEvent = ChatState -> EventM Name ChatState
forall (m :: * -> *) a. Monad m => a -> m a
return
, appAttrMap :: ChatState -> AttrMap
appAttrMap = (ChatState -> Getting AttrMap ChatState AttrMap -> AttrMap
forall s a. s -> Getting a s a -> a
^.(ChatResources -> Const AttrMap ChatResources)
-> ChatState -> Const AttrMap ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const AttrMap ChatResources)
-> ChatState -> Const AttrMap ChatState)
-> ((AttrMap -> Const AttrMap AttrMap)
-> ChatResources -> Const AttrMap ChatResources)
-> Getting AttrMap ChatState AttrMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(AttrMap -> Const AttrMap AttrMap)
-> ChatResources -> Const AttrMap ChatResources
Lens' ChatResources AttrMap
crTheme)
}
applicationMaxCPUs :: Int
applicationMaxCPUs :: Int
applicationMaxCPUs = Int
2
setupCpuUsage :: Config -> IO ()
setupCpuUsage :: Config -> IO ()
setupCpuUsage Config
config = do
Int
actualNumCpus <- IO Int
getNumProcessors
let requestedCPUs :: Int
requestedCPUs = case Config -> CPUUsagePolicy
configCpuUsagePolicy Config
config of
CPUUsagePolicy
SingleCPU -> Int
1
CPUUsagePolicy
MultipleCPUs -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
applicationMaxCPUs Int
actualNumCpus
Int -> IO ()
setNumCapabilities Int
requestedCPUs
runMatterhorn :: Options -> Config -> IO ChatState
runMatterhorn :: Options -> Config -> IO ChatState
runMatterhorn Options
opts Config
config = do
Config -> IO ()
setupCpuUsage Config
config
let mkVty :: IO Vty
mkVty = do
Maybe Char
mEraseChar <- Fd -> IO (Maybe Char)
Vty.getTtyEraseChar Fd
stdInput
let addEraseChar :: Config -> Config
addEraseChar Config
cfg = case Maybe Char
mEraseChar of
Maybe Char
Nothing -> Config
cfg
Just Char
ch -> Config
cfg { inputMap :: InputMap
Vty.inputMap = (Maybe String
forall a. Maybe a
Nothing, [Char
ch], Key -> [Modifier] -> Event
Vty.EvKey Key
Vty.KBS []) (Maybe String, String, Event) -> InputMap -> InputMap
forall a. a -> [a] -> [a]
: Config -> InputMap
Vty.inputMap Config
cfg }
Vty
vty <- Config -> IO Vty
Vty.mkVty (Config -> IO Vty) -> Config -> IO Vty
forall a b. (a -> b) -> a -> b
$ Config -> Config
addEraseChar Config
Vty.defaultConfig
let output :: Output
output = Vty -> Output
Vty.outputIface Vty
vty
Output -> Mode -> Bool -> IO ()
Vty.setMode Output
output Mode
Vty.BracketedPaste Bool
True
Output -> Mode -> Bool -> IO ()
Vty.setMode Output
output Mode
Vty.Hyperlink (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Bool
configHyperlinkingMode Config
config
Output -> Mode -> Bool -> IO ()
Vty.setMode Output
output Mode
Vty.Mouse (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Bool
configMouseMode Config
config
Vty -> IO Vty
forall (m :: * -> *) a. Monad m => a -> m a
return Vty
vty
(ChatState
st, Vty
vty) <- IO Vty -> Maybe String -> Config -> IO (ChatState, Vty)
setupState IO Vty
mkVty (Options -> Maybe String
optLogLocation Options
opts) Config
config
ChatState
finalSt <- Vty
-> IO Vty
-> Maybe (BChan MHEvent)
-> App ChatState MHEvent Name
-> ChatState
-> IO ChatState
forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO s
customMain Vty
vty IO Vty
mkVty (BChan MHEvent -> Maybe (BChan MHEvent)
forall a. a -> Maybe a
Just (BChan MHEvent -> Maybe (BChan MHEvent))
-> BChan MHEvent -> Maybe (BChan MHEvent)
forall a b. (a -> b) -> a -> b
$ ChatState
stChatState
-> Getting (BChan MHEvent) ChatState (BChan MHEvent)
-> BChan MHEvent
forall s a. s -> Getting a s a -> a
^.(ChatResources -> Const (BChan MHEvent) ChatResources)
-> ChatState -> Const (BChan MHEvent) ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const (BChan MHEvent) ChatResources)
-> ChatState -> Const (BChan MHEvent) ChatState)
-> ((BChan MHEvent -> Const (BChan MHEvent) (BChan MHEvent))
-> ChatResources -> Const (BChan MHEvent) ChatResources)
-> Getting (BChan MHEvent) ChatState (BChan MHEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BChan MHEvent -> Const (BChan MHEvent) (BChan MHEvent))
-> ChatResources -> Const (BChan MHEvent) ChatResources
Lens' ChatResources (BChan MHEvent)
crEventQueue) App ChatState MHEvent Name
app ChatState
st
[TeamState] -> (TeamState -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashMap TeamId TeamState -> [TeamState]
forall k v. HashMap k v -> [v]
HM.elems (HashMap TeamId TeamState -> [TeamState])
-> HashMap TeamId TeamState -> [TeamState]
forall a b. (a -> b) -> a -> b
$ ChatState
finalStChatState
-> Getting
(HashMap TeamId TeamState) ChatState (HashMap TeamId TeamState)
-> HashMap TeamId TeamState
forall s a. s -> Getting a s a -> a
^.Getting
(HashMap TeamId TeamState) ChatState (HashMap TeamId TeamState)
Lens' ChatState (HashMap TeamId TeamState)
csTeams) ((TeamState -> IO ()) -> IO ()) -> (TeamState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TeamState
ts ->
case TeamState
tsTeamState
-> Getting
(Maybe (Aspell, IO ())) TeamState (Maybe (Aspell, IO ()))
-> Maybe (Aspell, IO ())
forall s a. s -> Getting a s a -> a
^.(ChatEditState -> Const (Maybe (Aspell, IO ())) ChatEditState)
-> TeamState -> Const (Maybe (Aspell, IO ())) TeamState
Lens' TeamState ChatEditState
tsEditState((ChatEditState -> Const (Maybe (Aspell, IO ())) ChatEditState)
-> TeamState -> Const (Maybe (Aspell, IO ())) TeamState)
-> ((Maybe (Aspell, IO ())
-> Const (Maybe (Aspell, IO ())) (Maybe (Aspell, IO ())))
-> ChatEditState -> Const (Maybe (Aspell, IO ())) ChatEditState)
-> Getting
(Maybe (Aspell, IO ())) TeamState (Maybe (Aspell, IO ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe (Aspell, IO ())
-> Const (Maybe (Aspell, IO ())) (Maybe (Aspell, IO ())))
-> ChatEditState -> Const (Maybe (Aspell, IO ())) ChatEditState
Lens' ChatEditState (Maybe (Aspell, IO ()))
cedSpellChecker of
Maybe (Aspell, IO ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Aspell
s, IO ()
_) -> Aspell -> IO ()
stopAspell Aspell
s
ChatState -> IO ChatState
forall (m :: * -> *) a. Monad m => a -> m a
return ChatState
finalSt
closeMatterhorn :: ChatState -> IO ()
closeMatterhorn :: ChatState -> IO ()
closeMatterhorn ChatState
finalSt = do
IO () -> String -> IO ()
forall a. IO a -> String -> IO ()
logIfError (Session -> IO ()
mmCloseSession (Session -> IO ()) -> Session -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatResources -> Session
getResourceSession (ChatResources -> Session) -> ChatResources -> Session
forall a b. (a -> b) -> a -> b
$ ChatState
finalStChatState
-> Getting ChatResources ChatState ChatResources -> ChatResources
forall s a. s -> Getting a s a -> a
^.Getting ChatResources ChatState ChatResources
Lens' ChatState ChatResources
csResources)
String
"Error in closing session"
IO () -> String -> IO ()
forall a. IO a -> String -> IO ()
logIfError (InputHistory -> IO ()
writeHistory (ChatState
finalStChatState
-> Getting InputHistory ChatState InputHistory -> InputHistory
forall s a. s -> Getting a s a -> a
^.Getting InputHistory ChatState InputHistory
Lens' ChatState InputHistory
csInputHistory))
String
"Error in writing history"
IO () -> String -> IO ()
forall a. IO a -> String -> IO ()
logIfError (ChatState -> IO ()
writeLastRunStates ChatState
finalSt)
String
"Error in writing last run states"
LogManager -> IO ()
shutdownLogManager (LogManager -> IO ()) -> LogManager -> IO ()
forall a b. (a -> b) -> a -> b
$ ChatState
finalStChatState -> Getting LogManager ChatState LogManager -> LogManager
forall s a. s -> Getting a s a -> a
^.(ChatResources -> Const LogManager ChatResources)
-> ChatState -> Const LogManager ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const LogManager ChatResources)
-> ChatState -> Const LogManager ChatState)
-> ((LogManager -> Const LogManager LogManager)
-> ChatResources -> Const LogManager ChatResources)
-> Getting LogManager ChatState LogManager
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LogManager -> Const LogManager LogManager)
-> ChatResources -> Const LogManager ChatResources
Lens' ChatResources LogManager
crLogManager
where
logIfError :: IO a -> String -> IO ()
logIfError IO a
action String
msg = do
Either String a
done <- ExceptT String IO a -> IO (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO a -> IO (Either String a))
-> ExceptT String IO a -> IO (Either String a)
forall a b. (a -> b) -> a -> b
$ IO a -> ExceptT String IO a
forall a. IO a -> ExceptT String IO a
convertIOException (IO a -> ExceptT String IO a) -> IO a -> ExceptT String IO a
forall a b. (a -> b) -> a -> b
$ IO a
action
case Either String a
done of
Left String
err -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
Right a
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()