From 50240e7047eb2826f99b2607f489e05e82c06ba9 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 23 Mar 2021 12:48:17 -0400 Subject: [PATCH] Use `hoist` to simplify and de-dupe some instance definitions --- ChangeLog.md | 2 ++ reflex-vty.cabal | 1 + src/Reflex/Vty/Widget.hs | 11 +++--- src/Reflex/Vty/Widget/Layout.hs | 63 +++++++++++++++------------------ 4 files changed, 37 insertions(+), 40 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 6f524a7..8fe7698 100644 --- a/ChangeLog.md +++ b/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) diff --git a/reflex-vty.cabal b/reflex-vty.cabal index ce87325..295fb0c 100644 --- a/reflex-vty.cabal +++ b/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, diff --git a/src/Reflex/Vty/Widget.hs b/src/Reflex/Vty/Widget.hs index a3fddea..d5353d0 100644 --- a/src/Reflex/Vty/Widget.hs +++ b/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 diff --git a/src/Reflex/Vty/Widget/Layout.hs b/src/Reflex/Vty/Widget/Layout.hs index 0e4ffab..2745b7f 100644 --- a/src/Reflex/Vty/Widget/Layout.hs +++ b/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)