Adjustable instance for VtyWidget, and various supporting bits; Start of todo example

reflex-vty.cabal

@@ -17,11 +17,15 @@ library
                  , Reflex.Vty.Widget.Input
                  , Reflex.Vty.Widget.Input.Text
                  , Data.Text.Zipper
-  other-modules: Reflex.Spider.Orphans
+                 , Control.Monad.Writer.Adjustable
+                 , Reflex.Class.Switchable
+                 , Reflex.NotReady.Class.Orphans
+                 , Reflex.Spider.Orphans
   build-depends:
     base,
     containers,
     data-default,
+    dependent-map,
     dependent-sum,
     mtl,
     primitive,
@@ -41,6 +45,7 @@ executable example
   ghc-options: -threaded
   build-depends:
     base,
+    containers,
     reflex,
     reflex-vty,
     text,

src-bin/example.hs

@@ -3,26 +3,34 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -threaded #-}
 
 import Control.Monad.Fix
+import Data.Foldable
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Zipper as TZ
 import qualified Graphics.Vty as V
 import Reflex
+import Reflex.Network
+import Reflex.NotReady.Class
 import Reflex.Vty
 
 main :: IO ()
-main =
-  mainWidget $ do
-    inp <- input
-    tellShutdown . fforMaybe inp $ \case
-      V.EvKey V.KEsc _ -> Just ()
-      _ -> Nothing
-
-    debugInput
-    testBoxes
-    return ()
+main = mainWidget $ do
+  inp <- input
+  tellShutdown . fforMaybe inp $ \case
+    V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
+    _ -> Nothing
+  rec let todos' = todos [] $ () <$ e
+          btn = button $ pure "Add another task"
+      (_, e) <- splitV (pure (subtract 3)) (pure (True, True)) todos' btn
+  return ()
 
 testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
 testBoxes = do 
@@ -52,3 +60,68 @@ dragTest = do
 testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
 testStringBox = box singleBoxStyle .
   text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
+
+
+data Todo = Todo
+  { _todo_label :: Text
+  , _todo_done :: Bool
+  }
+  deriving (Show, Read, Eq, Ord)
+
+checkbox
+  :: (MonadHold t m, MonadFix m, Reflex t)
+  => Bool
+  -> VtyWidget t m (Dynamic t Bool)
+checkbox v0 = do
+  i <- input
+  v <- toggle v0 $ fforMaybe i $ \case
+    V.EvMouseUp _ _ _ -> Just ()
+    _ -> Nothing
+  text $ current $ ffor v $ \v' -> if v' then "[x]" else "[ ]"
+  return v
+
+button :: (Reflex t, Monad m) => Behavior t Text -> VtyWidget t m (Event t ())
+button t = do
+  box roundedBoxStyle $ text t
+  fmap (() <$) mouseUp
+
+todo
+  :: (MonadHold t m, MonadFix m, Reflex t)
+  => Todo
+  -> VtyWidget t m (Dynamic t Todo)
+todo t0 = do
+  w <- displayWidth
+  let checkboxWidth = 3
+      checkboxRegion = pure $ Region 0 0 checkboxWidth 1
+      labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
+  value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
+  label <- pane labelRegion (pure True) $
+    textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
+  return $ Todo <$> label <*> value
+
+todos
+  :: (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
+  => [Todo]
+  -> Event t ()
+  -> VtyWidget t m (Dynamic t (Seq Todo))
+todos todos0 newTodo = do
+  rec todos <- foldDyn ($) (Seq.fromList todos0) $ leftmost
+        [ (\ts -> ts Seq.|> Todo "" False) <$ newTodo
+        , (\(ix, t) -> Seq.update ix t) <$> updates
+        ]
+      w <- displayWidth
+      listOut <- networkView $ ffor todos $ \ts' ->
+        flip Seq.traverseWithIndex ts' $ \row t -> do
+          let reg = fmap (\w' -> Region 0 row w' 1) w
+          pane reg (fmap (==row) selected) $ do
+            e <- mouseUp
+            r <- todo t
+            return (row <$ e, (row,) <$> updated r)
+      selectionClick <- switchHold never $
+        fmap (leftmost . toList . fmap fst) listOut
+      selected <- holdDyn 0 $ leftmost
+        [ selectionClick
+        , Seq.length <$> tag (current todos) newTodo
+        ]
+      updates <- switchHold never $ fmap (leftmost . toList . fmap snd) listOut
+  return todos

src/Control/Monad/Writer/Adjustable.hs

@@ -0,0 +1,35 @@
+{-|
+Module: Control.Monad.Writer.Adjustable
+Description: An Adjustable instance for WriterT
+-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO find a better home for this
+module Control.Monad.Writer.Adjustable where
+
+import Control.Monad.Trans
+import Control.Monad.Trans.Writer
+import qualified Data.Dependent.Map as DMap
+import Data.Foldable (fold)
+import Data.Functor.Compose
+import Reflex
+import Reflex.Patch.DMapWithMove
+import Reflex.Class.Switchable
+
+instance (Adjustable t m, MonadHold t m, Switchable t w, Monoid w) => Adjustable t (WriterT w m) where
+  runWithReplace a0 a' = do
+    (w, r) <- lift $ runWithReplace (runWriterT a0) $ fmap (runWriterT) a'
+    tell =<< switching (snd w) (snd <$> r)
+    return $ (fst w, fst <$> r)
+  traverseIntMapWithKeyWithAdjust f dm0 dm' = do
+    (w, r) <- lift $ traverseIntMapWithKeyWithAdjust (\k v -> runWriterT (f k v)) dm0 dm'
+    tell =<< switching (fold $ fmap snd w) (fmap (mconcat . patchIntMapNewElements . fmap snd) r)
+    return (fmap fst w, fmap (fmap fst) r)
+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
+    (w, r) <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> fmap (\(x, w') -> Compose (w', x)) $ runWriterT (f k v)) dm0 dm'
+    let w' = runWriter $ DMap.traverseWithKey (\_ (Compose (w'', x)) -> tell w'' >> return x) w
+        r' = fmap (runWriter . traversePatchDMapWithMove (\(Compose (w'', x)) -> tell w'' >> return x)) r
+    tell =<< switching (snd w') (fmap snd r')
+    return (fst w', fmap fst r')

src/Reflex/Class/Switchable.hs

@@ -0,0 +1,30 @@
+{-|
+Module: Reflex.Class.Switchable
+Description: A class for things that can be switched on the firing of an event
+-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Reflex.Class.Switchable where
+
+import Control.Monad
+import Reflex
+
+-- | Class representing things that can be switched when the provided event occurs
+class Reflex t => Switchable t w | w -> t where
+  switching :: MonadHold t m => w -> Event t w -> m w
+
+instance Reflex t => Switchable t (Event t a) where
+  switching = switchHold
+
+instance Reflex t => Switchable t (Dynamic t a) where
+  switching a e = fmap join $ holdDyn a e
+
+instance Reflex t => Switchable t (Behavior t a) where
+  switching = switcher
+
+instance (Reflex t, Switchable t a, Switchable t b) => Switchable t (a, b) where
+  switching (a, b) e = (,)
+    <$> (switching a $ fmap fst e)
+    <*> (switching b $ fmap snd e)

src/Reflex/NotReady/Class/Orphans.hs

@@ -0,0 +1,17 @@
+{-|
+Module: Reflex.NotReady.Class.Orphans
+Description: Orphan instances for NotReady
+-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Reflex.NotReady.Class.Orphans where
+
+import Control.Monad.Trans
+import Control.Monad.Trans.Writer
+import Reflex.NotReady.Class
+
+instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where
+  notReadyUntil = lift . notReadyUntil
+  notReady = lift notReady

src/Reflex/Spider/Orphans.hs

@@ -1,3 +1,7 @@
+{-|
+Module: Reflex.Spider.Orphans
+Description: Orphan instances for SpiderTimeline and SpiderHost
+-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}

src/Reflex/Vty.hs

@@ -7,10 +7,6 @@ Maintainer  : maintainer@obsidian.systems
 Stability   : experimental
 Portability : POSIX
 -}
-
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 module Reflex.Vty
   ( module Reflex
   , module Reflex.Vty.Host

src/Reflex/Vty/Host.hs

@@ -75,6 +75,7 @@ type MonadVtyApp t m =
   , PerformEvent t m
   , MonadIO m
   , MonadIO (Performable m)
+  , Adjustable t m
   )
 
 -- | A functional reactive vty application.

src/Reflex/Vty/Widget.hs

@@ -11,7 +11,10 @@ Description: Basic set of widgets and building blocks for reflex-vty application
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Reflex.Vty.Widget
   ( VtyWidgetCtx(..)
   , VtyWidget(..)
@@ -32,6 +35,7 @@ module Reflex.Vty.Widget
   , MouseDown(..)
   , MouseUp(..)
   , mouseDown
+  , mouseUp
   , pane
   , modifyImages
   , tellImages
@@ -55,6 +59,7 @@ import Control.Monad.Fix (MonadFix)
 import Control.Monad.Trans (lift)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
 import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)
+import Control.Monad.Writer.Adjustable ()
 import Data.Default (Default(..))
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -62,6 +67,9 @@ import qualified Data.Text.Zipper as TZ
 import Graphics.Vty (Image)
 import qualified Graphics.Vty as V
 import Reflex
+import Reflex.Class.Switchable
+import Reflex.NotReady.Class
+import Reflex.NotReady.Class.Orphans ()
 
 import Reflex.Vty.Host
 
@@ -96,11 +104,32 @@ instance (Reflex t) => Monoid (VtyWidgetOut t) where
   mempty = VtyWidgetOut mempty mempty
   mappend wo wo' = wo <> wo'
 
+instance Reflex t => Switchable t (VtyWidgetOut t) where
+  switching e0 e = do
+    shutdown <- switching (_vtyWidgetOut_shutdown e0) $ fmap _vtyWidgetOut_shutdown e
+    images <- switching (_vtyWidgetOut_images e0) $ fmap _vtyWidgetOut_images e
+    return $ VtyWidgetOut
+      { _vtyWidgetOut_images = images
+      , _vtyWidgetOut_shutdown = shutdown
+      }
+
 -- | A widget that can read its context and produce image output
 newtype VtyWidget t m a = VtyWidget
   { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a
   }
-  deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix)
+  deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix, NotReady t)
+
+instance (PostBuild t m, Reflex t) => PostBuild t (VtyWidget t m) where
+  getPostBuild = VtyWidget $ lift getPostBuild
+
+instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where
+  runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'
+  traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $
+    traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
+  traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do
+    traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do
+    traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'
 
 -- | Runs a 'VtyWidget' with a given context
 runVtyWidget
@@ -128,7 +157,9 @@ mainWidgetWithHandle vty child =
           , _vtyWidgetCtx_input = inp'
           , _vtyWidgetCtx_focus = constDyn True
           }
-    ((), wo) <- runVtyWidget ctx child
+    ((), wo) <- runVtyWidget ctx $ do
+      tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
+      child
     return $ VtyResult
       { _vtyResult_picture = fmap (V.picForLayers . reverse) (_vtyWidgetOut_images wo)
       , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo
@@ -316,6 +347,16 @@ mouseDown btn = do
       else Nothing
     _ -> Nothing
 
+-- | Mouse up events for a particular mouse button
+mouseUp
+  :: (Reflex t, Monad m)
+  => VtyWidget t m (Event t MouseUp)
+mouseUp = do
+  i <- input
+  return $ fforMaybe i $ \case
+    V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
+    _ -> Nothing
+
 -- | Information about a mouse down event
 data MouseDown = MouseDown
   { _mouseDown_button :: V.Button