{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Swarm.TUI.Controller.EventHandlers (
createKeyDispatchers,
allEventHandlers,
mainEventHandlers,
replEventHandlers,
worldEventHandlers,
robotEventHandlers,
handleRobotPanelEvent,
runFrameUI,
runGameTickUI,
ticksPerFrameCap,
isRunning,
whenRunningAppState,
whenRunningPlayState,
runSingleTick,
adjustTPS,
toggleREPLVisibility,
showCESKDebug,
hideRobots,
toggleDiscoveryNotificationModal,
viewGoal,
toggleMessagesModal,
) where
import Brick hiding (on)
import Brick.Keybindings as BK
import Control.Effect.Accum
import Control.Effect.Throw
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Swarm.Failure (SystemFailure (..))
import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap)
import Swarm.TUI.Controller.EventHandlers.Main (adjustTPS, hideRobots, isRunning, mainEventHandlers, runSingleTick, showCESKDebug, toggleDiscoveryNotificationModal, toggleMessagesModal, toggleREPLVisibility, viewGoal, whenRunningAppState, whenRunningPlayState)
import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers)
import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, robotEventHandlers)
import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers)
import Swarm.TUI.Model
import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents)
import Swarm.Util (parens, squote)
createKeyDispatchers ::
(Has (Throw SystemFailure) sig m) =>
KeyConfig SwarmEvent ->
m SwarmKeyDispatchers
createKeyDispatchers :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
KeyConfig SwarmEvent -> m SwarmKeyDispatchers
createKeyDispatchers KeyConfig SwarmEvent
config = do
KeyDispatcher SwarmEvent (EventM Name AppState)
mainGameDispatcher <- [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
forall {m :: * -> *}.
[KeyEventHandler SwarmEvent m] -> m (KeyDispatcher SwarmEvent m)
buildDispatcher [KeyEventHandler SwarmEvent (EventM Name AppState)]
mainEventHandlers
let buildSubMainDispatcher :: Text
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
buildSubMainDispatcher = Text
-> KeyDispatcher SwarmEvent (EventM Name AppState)
-> Text
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
buildSubDispatcher Text
"Main game events" KeyDispatcher SwarmEvent (EventM Name AppState)
mainGameDispatcher
KeyDispatcher SwarmEvent (EventM Name AppState)
replDispatcher <- Text
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
buildSubMainDispatcher Text
"REPL panel events" [KeyEventHandler SwarmEvent (EventM Name AppState)]
replEventHandlers
KeyDispatcher SwarmEvent (EventM Name AppState)
worldDispatcher <- Text
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
buildSubMainDispatcher Text
"World view panel events" [KeyEventHandler SwarmEvent (EventM Name AppState)]
worldEventHandlers
KeyDispatcher SwarmEvent (EventM Name AppState)
robotDispatcher <- Text
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
buildSubMainDispatcher Text
"Robot inventory panel events" [KeyEventHandler SwarmEvent (EventM Name AppState)]
robotEventHandlers
SwarmKeyDispatchers -> m SwarmKeyDispatchers
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SwarmKeyDispatchers {KeyDispatcher SwarmEvent (EventM Name AppState)
mainGameDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
replDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
worldDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
robotDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
robotDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
worldDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
replDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
mainGameDispatcher :: KeyDispatcher SwarmEvent (EventM Name AppState)
..}
where
buildDispatcher :: [KeyEventHandler SwarmEvent m] -> m (KeyDispatcher SwarmEvent m)
buildDispatcher [KeyEventHandler SwarmEvent m]
handlers = case KeyConfig SwarmEvent
-> [KeyEventHandler SwarmEvent m]
-> Either
[(Binding, [KeyHandler SwarmEvent m])] (KeyDispatcher SwarmEvent m)
forall k (m :: * -> *).
Ord k =>
KeyConfig k
-> [KeyEventHandler k m]
-> Either [(Binding, [KeyHandler k m])] (KeyDispatcher k m)
keyDispatcher KeyConfig SwarmEvent
config [KeyEventHandler SwarmEvent m]
handlers of
Left [(Binding, [KeyHandler SwarmEvent m])]
collisions ->
[Text] -> m (KeyDispatcher SwarmEvent m)
forall {a}. [Text] -> m a
throwLoadingFailure ([Text] -> m (KeyDispatcher SwarmEvent m))
-> [Text] -> m (KeyDispatcher SwarmEvent m)
forall a b. (a -> b) -> a -> b
$
Text
"Error: some key events have the same keys bound to them.\n"
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [(Binding, [KeyHandler SwarmEvent m])] -> [Text]
forall {m :: * -> *}.
[(Binding, [KeyHandler SwarmEvent m])] -> [Text]
handlerErrors [(Binding, [KeyHandler SwarmEvent m])]
collisions
Right KeyDispatcher SwarmEvent m
d -> KeyDispatcher SwarmEvent m -> m (KeyDispatcher SwarmEvent m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return KeyDispatcher SwarmEvent m
d
buildSubDispatcher :: Text
-> KeyDispatcher SwarmEvent (EventM Name AppState)
-> Text
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
buildSubDispatcher Text
parentName KeyDispatcher SwarmEvent (EventM Name AppState)
parentDispatcher Text
name [KeyEventHandler SwarmEvent (EventM Name AppState)]
handlers = do
KeyDispatcher SwarmEvent (EventM Name AppState)
d <- [KeyEventHandler SwarmEvent (EventM Name AppState)]
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
forall {m :: * -> *}.
[KeyEventHandler SwarmEvent m] -> m (KeyDispatcher SwarmEvent m)
buildDispatcher [KeyEventHandler SwarmEvent (EventM Name AppState)]
handlers
let collisions :: [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
collisions = KeyDispatcher SwarmEvent (EventM Name AppState)
-> KeyDispatcher SwarmEvent (EventM Name AppState)
-> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
conflicts KeyDispatcher SwarmEvent (EventM Name AppState)
parentDispatcher KeyDispatcher SwarmEvent (EventM Name AppState)
d
if [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
collisions
then KeyDispatcher SwarmEvent (EventM Name AppState)
-> m (KeyDispatcher SwarmEvent (EventM Name AppState))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return KeyDispatcher SwarmEvent (EventM Name AppState)
d
else
[Text] -> m (KeyDispatcher SwarmEvent (EventM Name AppState))
forall {a}. [Text] -> m a
throwLoadingFailure ([Text] -> m (KeyDispatcher SwarmEvent (EventM Name AppState)))
-> [Text] -> m (KeyDispatcher SwarmEvent (EventM Name AppState))
forall a b. (a -> b) -> a -> b
$
(Text
"Error: some key events have keys bound to them in '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
parentName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' and in '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
-> [Text]
forall {m :: * -> *}.
[(Binding, [KeyHandler SwarmEvent m])] -> [Text]
handlerErrors [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
collisions
throwLoadingFailure :: [Text] -> m a
throwLoadingFailure = SystemFailure -> m a
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (SystemFailure -> m a)
-> ([Text] -> SystemFailure) -> [Text] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SystemFailure
CustomFailure (Text -> SystemFailure)
-> ([Text] -> Text) -> [Text] -> SystemFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"\n"
handlerErrors :: [(Binding, [KeyHandler SwarmEvent m])] -> [Text]
handlerErrors [(Binding, [KeyHandler SwarmEvent m])]
collisions = (((Binding, [KeyHandler SwarmEvent m]) -> Text)
-> [(Binding, [KeyHandler SwarmEvent m])] -> [Text])
-> [(Binding, [KeyHandler SwarmEvent m])]
-> ((Binding, [KeyHandler SwarmEvent m]) -> Text)
-> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Binding, [KeyHandler SwarmEvent m]) -> Text)
-> [(Binding, [KeyHandler SwarmEvent m])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [(Binding, [KeyHandler SwarmEvent m])]
collisions (((Binding, [KeyHandler SwarmEvent m]) -> Text) -> [Text])
-> ((Binding, [KeyHandler SwarmEvent m]) -> Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ \(Binding
b, [KeyHandler SwarmEvent m]
hs) ->
let hsm :: Text
hsm = Text
"Handlers with the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
squote (Binding -> Text
BK.ppBinding Binding
b) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" binding:"
hss :: [Text]
hss = ((KeyHandler SwarmEvent m -> Text)
-> [KeyHandler SwarmEvent m] -> [Text])
-> [KeyHandler SwarmEvent m]
-> (KeyHandler SwarmEvent m -> Text)
-> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (KeyHandler SwarmEvent m -> Text)
-> [KeyHandler SwarmEvent m] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [KeyHandler SwarmEvent m]
hs ((KeyHandler SwarmEvent m -> Text) -> [Text])
-> (KeyHandler SwarmEvent m -> Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ \KeyHandler SwarmEvent m
h ->
let trigger :: Text
trigger = case KeyEventHandler SwarmEvent m -> EventTrigger SwarmEvent
forall k (m :: * -> *). KeyEventHandler k m -> EventTrigger k
BK.kehEventTrigger (KeyEventHandler SwarmEvent m -> EventTrigger SwarmEvent)
-> KeyEventHandler SwarmEvent m -> EventTrigger SwarmEvent
forall a b. (a -> b) -> a -> b
$ KeyHandler SwarmEvent m -> KeyEventHandler SwarmEvent m
forall k (m :: * -> *). KeyHandler k m -> KeyEventHandler k m
BK.khHandler KeyHandler SwarmEvent m
h of
ByKey Binding
k -> Text
"triggered by the key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
squote (Binding -> Text
BK.ppBinding Binding
k)
ByEvent SwarmEvent
e -> Text
"triggered by the event " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown>" Text -> Text
squote (KeyEvents SwarmEvent -> SwarmEvent -> Maybe Text
forall k. Ord k => KeyEvents k -> k -> Maybe Text
BK.keyEventName KeyEvents SwarmEvent
swarmEvents SwarmEvent
e)
desc :: Text
desc = Handler m -> Text
forall (m :: * -> *). Handler m -> Text
BK.handlerDescription (Handler m -> Text) -> Handler m -> Text
forall a b. (a -> b) -> a -> b
$ KeyEventHandler SwarmEvent m -> Handler m
forall k (m :: * -> *). KeyEventHandler k m -> Handler m
BK.kehHandler (KeyEventHandler SwarmEvent m -> Handler m)
-> KeyEventHandler SwarmEvent m -> Handler m
forall a b. (a -> b) -> a -> b
$ KeyHandler SwarmEvent m -> KeyEventHandler SwarmEvent m
forall k (m :: * -> *). KeyHandler k m -> KeyEventHandler k m
BK.khHandler KeyHandler SwarmEvent m
h
in Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
trigger
in Text -> [Text] -> Text
T.intercalate Text
"\n" (Text
hsm Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
hss)
conflicts :: SwarmKeyDispatcher -> SwarmKeyDispatcher -> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
conflicts :: KeyDispatcher SwarmEvent (EventM Name AppState)
-> KeyDispatcher SwarmEvent (EventM Name AppState)
-> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
conflicts KeyDispatcher SwarmEvent (EventM Name AppState)
d1 KeyDispatcher SwarmEvent (EventM Name AppState)
d2 = NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> (Binding, [KeyHandler SwarmEvent (EventM Name AppState)])
forall k (m :: * -> *).
NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m])
combine (NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> (Binding, [KeyHandler SwarmEvent (EventM Name AppState)]))
-> [NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))]
badGroups
where
l1 :: [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
l1 = KeyDispatcher SwarmEvent (EventM Name AppState)
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall k (m :: * -> *).
KeyDispatcher k m -> [(Binding, KeyHandler k m)]
keyDispatcherToList KeyDispatcher SwarmEvent (EventM Name AppState)
d1
l2 :: [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
l2 = KeyDispatcher SwarmEvent (EventM Name AppState)
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall k (m :: * -> *).
KeyDispatcher k m -> [(Binding, KeyHandler k m)]
keyDispatcherToList KeyDispatcher SwarmEvent (EventM Name AppState)
d2
gs :: [NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))]
gs = ((Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> Binding)
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NE.groupWith (Binding, KeyHandler SwarmEvent (EventM Name AppState)) -> Binding
forall a b. (a, b) -> a
fst ([(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))])
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall a b. (a -> b) -> a -> b
$ ((Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> Binding)
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Binding, KeyHandler SwarmEvent (EventM Name AppState)) -> Binding
forall a b. (a, b) -> a
fst ([(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
l1 [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall a. Semigroup a => a -> a -> a
<> [(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
l2)
badGroups :: [NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))]
badGroups = (NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> Bool)
-> [NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
-> [NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) (Int -> Bool)
-> (NonEmpty
(Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> Int)
-> NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))
-> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [NonEmpty (Binding, KeyHandler SwarmEvent (EventM Name AppState))]
gs
combine :: NE.NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m])
combine :: forall k (m :: * -> *).
NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m])
combine NonEmpty (Binding, KeyHandler k m)
as =
let b :: Binding
b = (Binding, KeyHandler k m) -> Binding
forall a b. (a, b) -> a
fst ((Binding, KeyHandler k m) -> Binding)
-> (Binding, KeyHandler k m) -> Binding
forall a b. (a -> b) -> a -> b
$ NonEmpty (Binding, KeyHandler k m) -> (Binding, KeyHandler k m)
forall a. NonEmpty a -> a
NE.head NonEmpty (Binding, KeyHandler k m)
as
in (Binding
b, (Binding, KeyHandler k m) -> KeyHandler k m
forall a b. (a, b) -> b
snd ((Binding, KeyHandler k m) -> KeyHandler k m)
-> [(Binding, KeyHandler k m)] -> [KeyHandler k m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Binding, KeyHandler k m) -> [(Binding, KeyHandler k m)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Binding, KeyHandler k m)
as)
allEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)]
allEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)]
allEventHandlers =
[[KeyEventHandler SwarmEvent (EventM Name AppState)]]
-> [KeyEventHandler SwarmEvent (EventM Name AppState)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [KeyEventHandler SwarmEvent (EventM Name AppState)]
mainEventHandlers
, [KeyEventHandler SwarmEvent (EventM Name AppState)]
replEventHandlers
, [KeyEventHandler SwarmEvent (EventM Name AppState)]
worldEventHandlers
, [KeyEventHandler SwarmEvent (EventM Name AppState)]
robotEventHandlers
]