Focus lossage with networkHold in reflex-vty

exhibits.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -threaded #-}

import Data.Functor ((<&>))
import Control.Monad (join)
import Control.Monad.IO.Class
import Control.Monad.Fix
import Control.Monad.NodeId
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Graphics.Vty as V
import Reflex
import Reflex.Network
import Reflex.Vty
import System.Environment (getArgs)

exhibit1
  :: forall t m
  . ( Adjustable t m
    , MonadFix m, MonadHold t m, MonadNodeId m
    , PerformEvent t m, PostBuild t m
    , MonadIO (Performable m)
    , Reflex t
    , TriggerEvent t m)
  => [Text] -> VtyWidget t m ()
exhibit1 xs = mdo
  periodically <- tickLossyFromPostBuildTime 1
  ev <- updated <$> count periodically
  -- simulate user "input"
  let filtV = T.isInfixOf . (["a", "b", "c"] !!) . flip mod 3 <$> ev

  filtDE :: Dynamic t (Event t (Text -> Bool)) <-
    networkHold
    (menuiseWithInput xs)
    (menuiseWithInput . (flip filter xs)
     <$>
      filtV)
  pure ()
 where menuiseWithInput xs = menuise xs >> finput

exhibit2
  :: forall t m
  . ( Adjustable t m
    , MonadFix m, MonadHold t m, MonadNodeId m
    , PerformEvent t m, PostBuild t m
    , MonadIO (Performable m)
    , Reflex t
    , TriggerEvent t m)
  => [Text] -> VtyWidget t m ()
exhibit2 xs = mdo
  filtDE :: Dynamic t (Event t (Text -> Bool)) <-
    networkHold
    (menuiseWithInput xs)
    (menuiseWithInput . (flip filter xs)
     <$>
      (switch $ current filtDE))
  pure ()
 where menuiseWithInput xs = menuise xs >> finput

exhibit3
  :: forall t m
  . ( Adjustable t m
    , MonadFix m, MonadHold t m, MonadNodeId m
    , PerformEvent t m, PostBuild t m
    , MonadIO (Performable m)
    , Reflex t
    , TriggerEvent t m)
  => [Text] -> VtyWidget t m ()
exhibit3 xs = mdo
  filtD :: Dynamic t (Dynamic t (Text -> Bool)) <-
    networkHold
    (menuise xs >> finputDyn)
    ((attachWith (flip filter)
       (pure xs)
       (switch (current (updated <$> filtD))))
     <&>
      (\xs-> do
         menuise xs
         finputDyn))
  pure ()

finput
  :: (MonadFix m, MonadHold t m, MonadNodeId m, PostBuild t m, Reflex t)
  => VtyWidget t m (Event t (Text -> Bool))
finput = do
  TextInput txtD _ <- getInput
  pure $ T.isInfixOf <$> updated txtD

finputDyn
  :: (MonadFix m, MonadHold t m, MonadNodeId m, PostBuild t m, Reflex t)
  => VtyWidget t m (Dynamic t (Text -> Bool))
finputDyn = do
  TextInput txtD _ <- getInput
  holdDyn (const True) $ ffor (updated txtD) $
    \t-> (t `T.isInfixOf`)

menuise
  :: (MonadFix m, MonadHold t m, MonadNodeId m, PostBuild t m, Reflex t)
  => [Text]
  -> VtyWidget t m [Event t ()]
menuise = pane (DynRegion 0 1  80 9) (constDyn True)
          . col
          . traverse (fixed 3 . textButtonStatic def)

main :: IO ()
main = do
  args <- getArgs
  mainWidget $ do
    inp <- input
    let xs = ["aa", "ab", "ac"]
        choice = T.pack . fromMaybe "2" $ listToMaybe args
    text . pure $ "Exhibit " <> choice
    case choice of
      "1" -> exhibit1 xs
      "2" -> exhibit2 xs
      "3" -> exhibit2 xs
      _ -> error "Usage:  exhibit [1 | 2 | 3]"
    return $ fforMaybe inp $ \case
      V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
      _ -> Nothing

getInput
  :: (MonadFix m, MonadHold t m, MonadNodeId m, PostBuild t m, Reflex t)
  => VtyWidget t m (TextInput t)
getInput = pane (DynRegion 0 10 80 1) (pure True) $ col $ fixed 1 $ textInput def