-- | IO of thebrick application
module Dyna.Brick.Run(
  Spec(..),
  defSpec,
  emptyAttrMap,
  -- * Run application
  Run,
  runApp,
  -- * Sensors
  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 []

--------------------------------------------------------------------------------
-- run application

-- | Run application
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]

--------------------------------------------------------------------------------
-- event sensors

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)