module Dyna.Brick.Run(
Spec(..),
defSpec,
emptyAttrMap,
Run,
runApp,
vtyEvents,
mouseUp,
mouseDown,
keyEvents,
onChar,
onKey,
readChars,
module X,
Key(..),
Modifier(..),
) where
import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.MVar qualified as M
import Control.Monad.Reader
import Control.Monad.Base
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Concurrent.Chan.Unagi
import Control.Exception.Lifted
import Data.Default
import Data.Text (Text)
import Data.IORef
import Dyna qualified as D
import Brick as X
import Brick.Main (continueWithoutRedraw)
import Brick.BChan qualified as Brick
import qualified Graphics.Vty as Vty
import Graphics.Vty (Key(..), Modifier, Button)
import Dyna.Brick.Types
data Spec = Spec
{ Spec -> AttrMap
spec'attrMap :: AttrMap
, Spec -> [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
spec'cursor :: [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
}
instance Default Spec where
def :: Spec
def = AttrMap -> Spec
defSpec AttrMap
emptyAttrMap
defSpec :: AttrMap -> Spec
defSpec :: AttrMap -> Spec
defSpec AttrMap
attrs = AttrMap
-> ([CursorLocation BoxId] -> Maybe (CursorLocation BoxId)) -> Spec
Spec AttrMap
attrs (Maybe (CursorLocation BoxId)
-> [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
forall a b. a -> b -> a
const Maybe (CursorLocation BoxId)
forall a. Maybe a
Nothing)
emptyAttrMap :: AttrMap
emptyAttrMap :: AttrMap
emptyAttrMap = Attr -> [(AttrName, Attr)] -> AttrMap
attrMap Attr
Vty.defAttr []
runApp :: Spec -> Run Win -> IO ()
runApp :: Spec -> Run Win -> IO ()
runApp Spec{AttrMap
[CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
spec'cursor :: [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
spec'attrMap :: AttrMap
spec'cursor :: Spec -> [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
spec'attrMap :: Spec -> AttrMap
..} Run Win
dynActs = do
Env
env <- IO Env
newEnv
BChan InternalEvent
actChan <- Int -> IO (BChan InternalEvent)
forall a. Int -> IO (BChan a)
Brick.newBChan Int
10
let app :: App [Widget BoxId] InternalEvent BoxId
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 :: [Widget BoxId] -> [Widget BoxId]
appDraw = [Widget BoxId] -> [Widget BoxId]
forall a. a -> a
id
, appChooseCursor :: [Widget BoxId]
-> [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
appChooseCursor = ([CursorLocation BoxId] -> Maybe (CursorLocation BoxId))
-> [Widget BoxId]
-> [CursorLocation BoxId]
-> Maybe (CursorLocation BoxId)
forall a b. a -> b -> a
const [CursorLocation BoxId] -> Maybe (CursorLocation BoxId)
spec'cursor
, appHandleEvent :: [Widget BoxId]
-> BrickEvent BoxId InternalEvent
-> EventM BoxId (Next [Widget BoxId])
appHandleEvent = Env
-> [Widget BoxId]
-> BrickEvent BoxId InternalEvent
-> EventM BoxId (Next [Widget BoxId])
forall n.
Env
-> [Widget BoxId]
-> BrickEvent BoxId InternalEvent
-> EventM n (Next [Widget BoxId])
handleEvent Env
env
, appStartEvent :: [Widget BoxId] -> EventM BoxId [Widget BoxId]
appStartEvent = [Widget BoxId] -> EventM BoxId [Widget BoxId]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
, appAttrMap :: [Widget BoxId] -> AttrMap
appAttrMap = AttrMap -> [Widget BoxId] -> AttrMap
forall a b. a -> b -> a
const AttrMap
spec'attrMap
}
let evs :: Run (Evt Run InternalEvent)
evs = (\(Win Dyn [Widget BoxId]
dyn Evt Act
acts) -> ([Widget BoxId] -> InternalEvent
UpdateWidgets ([Widget BoxId] -> InternalEvent)
-> Evt Run [Widget BoxId] -> Evt Run InternalEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dyn Run [Widget BoxId] -> Evt Run [Widget BoxId]
forall (m :: * -> *) a. Frp m => Dyn m a -> Evt m a
D.unhold (Dyn [Widget BoxId] -> Dyn Run [Widget BoxId]
forall a. Dyn a -> Dyn Run a
unDyn Dyn [Widget BoxId]
dyn)) Evt Run InternalEvent
-> Evt Run InternalEvent -> Evt Run InternalEvent
forall a. Semigroup a => a -> a -> a
<> (Act -> InternalEvent
BrickAct (Act -> InternalEvent) -> Evt Run Act -> Evt Run InternalEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Evt Act -> Evt Run Act
forall a. Evt a -> Evt Run a
unEvt Evt Act
acts)) (Win -> Evt Run InternalEvent)
-> Run Win -> Run (Evt Run InternalEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Run Win
dynActs
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Run () -> Env -> IO ()
forall a. Run a -> Env -> IO a
evalRun ((\Evt Run InternalEvent
e -> Evt Run InternalEvent -> (InternalEvent -> Run ()) -> Run ()
forall (m :: * -> *) a. Evt m a -> (a -> m ()) -> m ()
D.runEvt Evt Run InternalEvent
e (IO () -> Run ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Run ())
-> (InternalEvent -> IO ()) -> InternalEvent -> Run ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BChan InternalEvent -> InternalEvent -> IO ()
forall a. BChan a -> a -> IO ()
Brick.writeBChan BChan InternalEvent
actChan)) (Evt Run InternalEvent -> Run ())
-> Run (Evt Run InternalEvent) -> Run ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Run (Evt Run InternalEvent)
evs) Env
env
BChan InternalEvent
-> App [Widget BoxId] InternalEvent BoxId -> IO ()
forall n e n. Ord n => BChan e -> App [Widget n] e n -> IO ()
runChanMain BChan InternalEvent
actChan App [Widget BoxId] InternalEvent BoxId
app
IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`finally` ThreadId -> IO ()
killThread ThreadId
tid
where
handleEvent :: Env
-> [Widget BoxId]
-> BrickEvent BoxId InternalEvent
-> EventM n (Next [Widget BoxId])
handleEvent env :: Env
env@Env{UChan Event
UChan MouseUpEvent
UChan MouseDownEvent
env'mouseUpChan :: Env -> UChan MouseUpEvent
env'mouseDownChan :: Env -> UChan MouseDownEvent
env'eventChan :: Env -> UChan Event
env'mouseUpChan :: UChan MouseUpEvent
env'mouseDownChan :: UChan MouseDownEvent
env'eventChan :: UChan Event
..} [Widget BoxId]
st BrickEvent BoxId InternalEvent
evt = case BrickEvent BoxId InternalEvent
evt of
VtyEvent Event
event -> do
IO () -> EventM n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM n ()) -> IO () -> EventM n ()
forall a b. (a -> b) -> a -> b
$ InChan Event -> Event -> IO ()
forall a. InChan a -> a -> IO ()
writeChan (UChan Event -> InChan Event
forall a b. (a, b) -> a
fst UChan Event
env'eventChan) Event
event
[Widget BoxId] -> EventM n (Next [Widget BoxId])
forall s n. s -> EventM n (Next s)
continueWithoutRedraw [Widget BoxId]
st
AppEvent InternalEvent
act -> case InternalEvent
act of
UpdateWidgets [Widget BoxId]
ws -> [Widget BoxId] -> EventM n (Next [Widget BoxId])
forall s n. s -> EventM n (Next s)
continue [Widget BoxId]
ws
BrickAct Act
act ->
case Act
act of
Act
Quit -> [Widget BoxId] -> EventM n (Next [Widget BoxId])
forall s n. s -> EventM n (Next s)
halt [Widget BoxId]
st
MouseDown BoxId
n Button
but [Modifier]
mods Location
loc -> do
IO () -> EventM n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM n ()) -> IO () -> EventM n ()
forall a b. (a -> b) -> a -> b
$ InChan MouseDownEvent -> MouseDownEvent -> IO ()
forall a. InChan a -> a -> IO ()
writeChan (UChan MouseDownEvent -> InChan MouseDownEvent
forall a b. (a, b) -> a
fst UChan MouseDownEvent
env'mouseDownChan) (BoxId -> Button -> [Modifier] -> Location -> MouseDownEvent
MouseDownEvent BoxId
n Button
but [Modifier]
mods Location
loc)
[Widget BoxId] -> EventM n (Next [Widget BoxId])
forall s n. s -> EventM n (Next s)
continueWithoutRedraw [Widget BoxId]
st
MouseUp BoxId
n Maybe Button
mBut Location
loc -> do
IO () -> EventM n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM n ()) -> IO () -> EventM n ()
forall a b. (a -> b) -> a -> b
$ InChan MouseUpEvent -> MouseUpEvent -> IO ()
forall a. InChan a -> a -> IO ()
writeChan (UChan MouseUpEvent -> InChan MouseUpEvent
forall a b. (a, b) -> a
fst UChan MouseUpEvent
env'mouseUpChan) (BoxId -> Maybe Button -> Location -> MouseUpEvent
MouseUpEvent BoxId
n Maybe Button
mBut Location
loc)
[Widget BoxId] -> EventM n (Next [Widget BoxId])
forall s n. s -> EventM n (Next s)
continueWithoutRedraw [Widget BoxId]
st
runChanMain :: BChan e -> App [Widget n] e n -> IO ()
runChanMain BChan e
chan App [Widget n] e n
app = do
let buildVty :: IO Vty
buildVty = Config -> IO Vty
Vty.mkVty Config
Vty.defaultConfig
Vty
initialVty <- IO Vty
buildVty
IO [Widget n] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Widget n] -> IO ()) -> IO [Widget n] -> IO ()
forall a b. (a -> b) -> a -> b
$ Vty
-> IO Vty
-> Maybe (BChan e)
-> App [Widget n] e n
-> [Widget n]
-> IO [Widget n]
forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO s
customMain Vty
initialVty IO Vty
buildVty (BChan e -> Maybe (BChan e)
forall a. a -> Maybe a
Just BChan e
chan) App [Widget n] e n
app [Widget n
forall n. Widget n
emptyWidget]
vtyEvents :: Evt Vty.Event
vtyEvents :: Evt Event
vtyEvents = Evt Run Event -> Evt Event
forall a. Evt Run a -> Evt a
Evt (Evt Run Event -> Evt Event) -> Evt Run Event -> Evt Event
forall a b. (a -> b) -> a -> b
$ ((Event -> Run ()) -> Run ()) -> Evt Run Event
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Evt m a
D.Evt (((Event -> Run ()) -> Run ()) -> Evt Run Event)
-> ((Event -> Run ()) -> Run ()) -> Evt Run Event
forall a b. (a -> b) -> a -> b
$ \Event -> Run ()
go -> do
InChan Event
eventChan <- UChan Event -> InChan Event
forall a b. (a, b) -> a
fst (UChan Event -> InChan Event)
-> Run (UChan Event) -> Run (InChan Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> UChan Event) -> Run (UChan Event)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> UChan Event
env'eventChan
Evt Run Event -> (Event -> Run ()) -> Run ()
forall (m :: * -> *) a. Evt m a -> (a -> m ()) -> m ()
D.runEvt (InChan Event -> Evt Run Event
forall (m :: * -> *) a. Frp m => InChan a -> Evt m a
D.uchanEvt InChan Event
eventChan) Event -> Run ()
go
mouseDown :: Evt MouseDownEvent
mouseDown :: Evt MouseDownEvent
mouseDown = Evt Run MouseDownEvent -> Evt MouseDownEvent
forall a. Evt Run a -> Evt a
Evt (Evt Run MouseDownEvent -> Evt MouseDownEvent)
-> Evt Run MouseDownEvent -> Evt MouseDownEvent
forall a b. (a -> b) -> a -> b
$ ((MouseDownEvent -> Run ()) -> Run ()) -> Evt Run MouseDownEvent
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Evt m a
D.Evt (((MouseDownEvent -> Run ()) -> Run ()) -> Evt Run MouseDownEvent)
-> ((MouseDownEvent -> Run ()) -> Run ()) -> Evt Run MouseDownEvent
forall a b. (a -> b) -> a -> b
$ \MouseDownEvent -> Run ()
go -> do
InChan MouseDownEvent
mouseDownChan <- UChan MouseDownEvent -> InChan MouseDownEvent
forall a b. (a, b) -> a
fst (UChan MouseDownEvent -> InChan MouseDownEvent)
-> Run (UChan MouseDownEvent) -> Run (InChan MouseDownEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> UChan MouseDownEvent) -> Run (UChan MouseDownEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> UChan MouseDownEvent
env'mouseDownChan
Evt Run MouseDownEvent -> (MouseDownEvent -> Run ()) -> Run ()
forall (m :: * -> *) a. Evt m a -> (a -> m ()) -> m ()
D.runEvt (InChan MouseDownEvent -> Evt Run MouseDownEvent
forall (m :: * -> *) a. Frp m => InChan a -> Evt m a
D.uchanEvt InChan MouseDownEvent
mouseDownChan) MouseDownEvent -> Run ()
go
mouseUp :: Evt MouseUpEvent
mouseUp :: Evt MouseUpEvent
mouseUp = Evt Run MouseUpEvent -> Evt MouseUpEvent
forall a. Evt Run a -> Evt a
Evt (Evt Run MouseUpEvent -> Evt MouseUpEvent)
-> Evt Run MouseUpEvent -> Evt MouseUpEvent
forall a b. (a -> b) -> a -> b
$ ((MouseUpEvent -> Run ()) -> Run ()) -> Evt Run MouseUpEvent
forall (m :: * -> *) a. ((a -> m ()) -> m ()) -> Evt m a
D.Evt (((MouseUpEvent -> Run ()) -> Run ()) -> Evt Run MouseUpEvent)
-> ((MouseUpEvent -> Run ()) -> Run ()) -> Evt Run MouseUpEvent
forall a b. (a -> b) -> a -> b
$ \MouseUpEvent -> Run ()
go -> do
InChan MouseUpEvent
mouseUpChan <- UChan MouseUpEvent -> InChan MouseUpEvent
forall a b. (a, b) -> a
fst (UChan MouseUpEvent -> InChan MouseUpEvent)
-> Run (UChan MouseUpEvent) -> Run (InChan MouseUpEvent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env -> UChan MouseUpEvent) -> Run (UChan MouseUpEvent)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> UChan MouseUpEvent
env'mouseUpChan
Evt Run MouseUpEvent -> (MouseUpEvent -> Run ()) -> Run ()
forall (m :: * -> *) a. Evt m a -> (a -> m ()) -> m ()
D.runEvt (InChan MouseUpEvent -> Evt Run MouseUpEvent
forall (m :: * -> *) a. Frp m => InChan a -> Evt m a
D.uchanEvt InChan MouseUpEvent
mouseUpChan) MouseUpEvent -> Run ()
go
keyEvents :: Evt (Key, [Modifier])
keyEvents :: Evt (Key, [Modifier])
keyEvents = Evt Run (Key, [Modifier]) -> Evt (Key, [Modifier])
forall a. Evt Run a -> Evt a
Evt (Evt Run (Key, [Modifier]) -> Evt (Key, [Modifier]))
-> Evt Run (Key, [Modifier]) -> Evt (Key, [Modifier])
forall a b. (a -> b) -> a -> b
$ (Event -> Maybe (Key, [Modifier]))
-> Evt Run Event -> Evt Run (Key, [Modifier])
forall (m :: * -> *) a b.
Frp m =>
(a -> Maybe b) -> Evt m a -> Evt m b
D.mapMay Event -> Maybe (Key, [Modifier])
go (Evt Event -> Evt Run Event
forall a. Evt a -> Evt Run a
unEvt Evt Event
vtyEvents)
where
go :: Event -> Maybe (Key, [Modifier])
go = \case
Vty.EvKey Key
key [Modifier]
mods -> (Key, [Modifier]) -> Maybe (Key, [Modifier])
forall a. a -> Maybe a
Just (Key
key, [Modifier]
mods)
Event
_ -> Maybe (Key, [Modifier])
forall a. Maybe a
Nothing
onChar :: Char -> Evt [Modifier]
onChar :: Char -> Evt [Modifier]
onChar Char
ch = Key -> Evt [Modifier]
onKey (Char -> Key
KChar Char
ch)
readChars :: Evt Char
readChars :: Evt Char
readChars = Evt Run Char -> Evt Char
forall a. Evt Run a -> Evt a
Evt (Evt Run Char -> Evt Char) -> Evt Run Char -> Evt Char
forall a b. (a -> b) -> a -> b
$ ((Key, [Modifier]) -> Maybe Char)
-> Evt Run (Key, [Modifier]) -> Evt Run Char
forall (m :: * -> *) a b.
Frp m =>
(a -> Maybe b) -> Evt m a -> Evt m b
D.mapMay (Key, [Modifier]) -> Maybe Char
forall b. (Key, b) -> Maybe Char
go (Evt (Key, [Modifier]) -> Evt Run (Key, [Modifier])
forall a. Evt a -> Evt Run a
unEvt Evt (Key, [Modifier])
keyEvents)
where
go :: (Key, b) -> Maybe Char
go (Key, b)
x = case (Key, b) -> Key
forall a b. (a, b) -> a
fst (Key, b)
x of
KChar Char
ch -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
ch
Key
_ -> Maybe Char
forall a. Maybe a
Nothing
onKey :: Key -> Evt [Modifier]
onKey :: Key -> Evt [Modifier]
onKey Key
k = Evt Run [Modifier] -> Evt [Modifier]
forall a. Evt Run a -> Evt a
Evt (Evt Run [Modifier] -> Evt [Modifier])
-> Evt Run [Modifier] -> Evt [Modifier]
forall a b. (a -> b) -> a -> b
$
((Key, [Modifier]) -> Maybe [Modifier])
-> Evt Run (Key, [Modifier]) -> Evt Run [Modifier]
forall (m :: * -> *) a b.
Frp m =>
(a -> Maybe b) -> Evt m a -> Evt m b
D.mapMay
(\(Key
x, [Modifier]
mods) -> if Key
x Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
k then [Modifier] -> Maybe [Modifier]
forall a. a -> Maybe a
Just [Modifier]
mods else Maybe [Modifier]
forall a. Maybe a
Nothing)
(Evt (Key, [Modifier]) -> Evt Run (Key, [Modifier])
forall a. Evt a -> Evt Run a
unEvt Evt (Key, [Modifier])
keyEvents)