Use hoist to simplify and de-dupe some instance definitions

ChangeLog.md

@@ -52,6 +52,8 @@
 * Add `anyChildFocused`, which provides information about whether subwidgets are focused
 * Add `filterKeys`, which is the same as `localInput` but only cares about keyboard events
 * _Breaking Change_: `ImageWriter` now has a method `mapImages` for transforming the images emitted by a child widget
+* Add `hoistRunLayout` to apply a transformation to the context of a `Layout` action and run that action
+* Add an `MFunctor` instance for `VtyWidget`
 
 ## 0.1.4.1
 * Migrate to new dependent-sum / dependent-map (after the "some" package split)

reflex-vty.cabal

@@ -42,6 +42,7 @@ library
     text >= 1.2.3 && < 1.3,
     dependent-sum >= 0.7 && < 0.8,
     exception-transformers >= 0.4.0 && < 0.5,
+    mmorph >= 1.1 && < 1.2,
     ordered-containers >= 0.2.2 && < 0.3,
     primitive >= 0.6.3 && < 0.8,
     ref-tf >= 0.4.0 && < 0.5,

src/Reflex/Vty/Widget.hs

@@ -59,6 +59,7 @@ module Reflex.Vty.Widget
 import Control.Applicative (liftA2)
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Morph
 import Control.Monad.NodeId
 import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
 import Control.Monad.Trans (MonadTrans, lift)
@@ -120,9 +121,13 @@ newtype VtyWidget t m a = VtyWidget
     )
 
 deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
+
 instance MonadTrans (VtyWidget t) where
   lift f = VtyWidget $ lift $ lift $ lift f
 
+instance MFunctor (VtyWidget t) where
+  hoist f = VtyWidget . hoist (hoist (hoist f)) . unVtyWidget
+
 instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
   getNextNodeId = VtyWidget $ do
     lift $ lift getNextNodeId
@@ -219,11 +224,7 @@ filterKeys f x = localInput (ffilter (\case
 
 instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
   input = VtyWidget . lift $ lift $ ask
-  localInput f (VtyWidget m) = VtyWidget $ do
-    ctx <- ask
-    (a, images) <- lift $ lift $ local f $ runReaderT (runBehaviorWriterT m) ctx
-    tellImages images
-    pure a
+  localInput f (VtyWidget m) = VtyWidget $ hoist (hoist (local f)) m
 
 -- | A class for things that can dynamically gain and lose focus
 class HasFocus t m | m -> t where

src/Reflex/Vty/Widget/Layout.hs

@@ -7,6 +7,7 @@ Description: Monad transformer and tools for arranging widgets and building scre
 module Reflex.Vty.Widget.Layout where
 
 import Control.Applicative (liftA2)
+import Control.Monad.Morph
 import Control.Monad.NodeId (MonadNodeId(..), NodeId)
 import Control.Monad.Reader
 import Data.List (mapAccumL)
@@ -113,6 +114,9 @@ newtype Focus t m a = Focus
 instance MonadTrans (Focus t) where
   lift = Focus . lift . lift . lift
 
+instance MFunctor (Focus t) where
+  hoist f = Focus . hoist (hoist (hoist f)) . unFocus
+
 instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m) where
   runWithReplace (Focus a) e = Focus $ runWithReplace a $ fmap unFocus e
   traverseIntMapWithKeyWithAdjust f m e = Focus $ traverseIntMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
@@ -120,29 +124,13 @@ instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m)
   traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
 
 instance (Reflex t, MonadFix m, HasVtyInput t m) => HasVtyInput t (Focus t m) where
-  localInput f (Focus w) = Focus $ do
-    d <- ask
-    ((a, fs), e) <- lift $ lift $ lift $
-      localInput f $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
-    tellEvent e
-    tellDyn fs
-    return a
+  localInput f = hoist (localInput f)
 
 instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
-  localCtx f (Focus w) = Focus $ do
-    d <- ask
-    ((a, fs), e) <- lift $ lift $ lift $ localCtx f $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
-    tellEvent e
-    tellDyn fs
-    return a
+  localCtx f = hoist (localCtx f)
 
 instance (ImageWriter t m, MonadFix m) => ImageWriter t (Focus t m) where
-  mapImages f (Focus w) = Focus $ do
-    d <- ask
-    ((a, fs), e) <- lift $ lift $ lift $ mapImages f $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
-    tellEvent e
-    tellDyn fs
-    return a
+  mapImages f = hoist (mapImages f)
 
 instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)
 
@@ -382,6 +370,9 @@ newtype Layout t m a = Layout
 instance MonadTrans (Layout t) where
   lift = Layout . lift . lift
 
+instance MFunctor (Layout t) where
+  hoist f = Layout . hoist (hoist f) . unLayout
+
 instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
   runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
   traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
@@ -398,25 +389,27 @@ instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasV
       let reg = Region 0 0 <$> dw <*> dh
       runLayout orientation reg x
 
+-- | Apply a transformation to the context of a child 'Layout' action and run
+-- that action
+hoistRunLayout
+  :: (HasDisplaySize t m, MonadFix m, Monad n)
+  => (m a -> n b)
+  -> Layout t m a
+  -> Layout t n b
+hoistRunLayout f x = do
+  solution <- Layout ask
+  let orientation = snd . rootLT <$> solution
+  lift $ f $ do
+    dw <- displayWidth
+    dh <- displayHeight
+    let reg = Region 0 0 <$> dw <*> dh
+    runLayout orientation reg x
+
 instance (HasVtyInput t m, HasDisplaySize t m, MonadFix m, Reflex t) => HasVtyInput t (Layout t m) where
-  localInput f x = do
-    solution <- Layout ask
-    let orientation = snd . rootLT <$> solution
-    lift $ localInput f $ do
-      dw <- displayWidth
-      dh <- displayHeight
-      let reg = Region 0 0 <$> dw <*> dh
-      runLayout orientation reg x
+  localInput = hoistRunLayout . localInput
 
 instance (HasDisplaySize t m, ImageWriter t m, MonadFix m) => ImageWriter t (Layout t m) where
-  mapImages f x = do
-    solution <- Layout ask
-    let orientation = snd . rootLT <$> solution
-    lift $ mapImages f $ do
-      dw <- displayWidth
-      dh <- displayHeight
-      let reg = Region 0 0 <$> dw <*> dh
-      runLayout orientation reg x
+  mapImages f = hoistRunLayout (mapImages f)
 
 instance (HasFocus t m, Monad m) => HasFocus t (Layout t m)