@@ -2,6 +2,7 @@
22Module: Reflex.Vty.Widget
33Description: Basic set of widgets and building blocks for reflex-vty applications
44-}
5+{-# LANGUAGE DefaultSignatures #-}
56{-# LANGUAGE DeriveFunctor #-}
67{-# LANGUAGE FlexibleContexts #-}
78{-# LANGUAGE FlexibleInstances #-}
@@ -17,6 +18,7 @@ Description: Basic set of widgets and building blocks for reflex-vty application
1718{-# LANGUAGE TupleSections #-}
1819{-# LANGUAGE TypeFamilies #-}
1920{-# LANGUAGE UndecidableInstances #-}
21+
2022module Reflex.Vty.Widget
2123 ( VtyWidgetCtx(..)
2224 , VtyWidget(..)
@@ -25,14 +27,6 @@ module Reflex.Vty.Widget
2527 , runVtyWidget
2628 , mainWidget
2729 , mainWidgetWithHandle
28−
29− , StackWidget(..)
30− , stack
31− , Direction(..)
32− , col
33− , row
34− , sized
35−
3630 , HasDisplaySize(..)
3731 , HasFocus(..)
3832 , HasVtyInput(..)
@@ -68,15 +62,30 @@ module Reflex.Vty.Widget
6862 , key
6963 , keys
7064 , keyCombos
65+ , SizedWidget
66+ , StackT
67+ , StackConfig(..)
68+ , StackWidget(..)
69+ , stack
70+ , Direction(..)
71+ , askDirection
72+ , askRemainingSpace
73+ , askOffset
74+ , col
75+ , row
76+ , fixed
77+ , fraction
78+ , remaining
79+ , tile
7180 ) where
7281
7382import Control.Applicative (liftA2)
74−import Control.Monad (ap)
83+import Control.Monad.TimeMachine
7584import Control.Monad.Fix (MonadFix)
85+import Control.Monad.Trans.Class
7686import Control.Monad.Trans (lift)
77−import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)
87+import Control.Monad.Reader
7888import Data.Default (Default(..))
79−import Data.Monoid (Sum(..))
8089import Data.Set (Set)
8190import qualified Data.Set as Set
8291import Data.Text (Text)
@@ -85,6 +94,7 @@ import qualified Data.Text.Zipper as TZ
8594import Graphics.Vty (Image)
8695import qualified Graphics.Vty as V
8796import Reflex
97+import Reflex.Class ()
8898import Reflex.Class.Orphans ()
8999import Reflex.NotReady.Class
90100import Reflex.NotReady.Class.Orphans ()
@@ -125,7 +135,7 @@ instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t
125135newtype VtyWidget t m a = VtyWidget
126136 { unVtyWidget :: BehaviorWriterT t [Image] (ReaderT (VtyWidgetCtx t) m) a
127137 }
128− deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix, NotReady t, ImageWriter t)
138+ deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix, NotReady t, ImageWriter t, PostBuild t)
129139
130140-- | Runs a 'VtyWidget' with a given context
131141runVtyWidget
@@ -174,13 +184,23 @@ mainWidget child = do
174184class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
175185 -- | Retrieve the display width (columns)
176186 displayWidth :: m (Dynamic t Int)
187+ default displayWidth :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
188+ displayWidth = lift displayWidth
177189 -- | Retrieve the display height (rows)
178190 displayHeight :: m (Dynamic t Int)
179−
191+ default displayHeight :: (f m' ~ m, MonadTrans f, HasDisplaySize t m') => m (Dynamic t Int)
192+ displayHeight = lift displayHeight
180193instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
181194 displayWidth = VtyWidget . lift $ asks _vtyWidgetCtx_width
182195 displayHeight = VtyWidget . lift $ asks _vtyWidgetCtx_height
183196
197+instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)
198+instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)
199+instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)
200+instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)
201+
202+instance (MonadFix m, HasDisplaySize t m) => HasDisplaySize t (TimeMachineT back fwd m)
203+
184204-- | A class for things that can receive vty events as input
185205class HasVtyInput t m | m -> t where
186206 input :: m (Event t VtyEvent)
@@ -290,8 +310,6 @@ pane dr foc child = VtyWidget $ do
290310 | otherwise =
291311 Just (con (x - l) (y - t))
292312
293−
294−
295313-- | Information about a drag operation
296314data Drag = Drag
297315 { _drag_from :: (Int, Int) -- ^ Where the drag began
@@ -371,14 +389,18 @@ data MouseUp = MouseUp
371389 }
372390 deriving (Eq, Ord, Show)
373391
392+-- | Type synonym for a key and modifier combination
374393type KeyCombo = (V.Key, [V.Modifier])
375394
395+-- | Emits an event that fires on a particular key press (without modifiers)
376396key :: (Monad m, Reflex t) => V.Key -> VtyWidget t m (Event t KeyCombo)
377397key = keyCombos . Set.singleton . (,[])
378398
399+-- | Emits an event that fires on particular key presses (without modifiers)
379400keys :: (Monad m, Reflex t) => [V.Key] -> VtyWidget t m (Event t KeyCombo)
380401keys = keyCombos . Set.fromList . fmap (,[])
381402
403+-- | Emit an event that fires whenever any of the provided key combinations occur
382404keyCombos
383405 :: (Reflex t, Monad m)
384406 => Set KeyCombo
@@ -600,65 +622,169 @@ display
600622 -> VtyWidget t m ()
601623display a = text $ T.pack . show <$> a
602624
625+-- | The main-axis orientation of a 'StackWidget' widget
603626data Direction = Direction_Column
604627 | Direction_Row
605628 deriving (Show, Read, Eq, Ord)
606629
607−newtype StackWidget t m a = StackWidget { unStackWidget :: ReaderT Direction (DynamicWriterT t (Sum Int) (VtyWidget t m)) a }
608− deriving (Functor, MonadSample t, MonadHold t, MonadFix, NotReady t)
609−
610−instance (Reflex t, MonadFix m) => Applicative (StackWidget t m) where
611− pure = return
612− (<*>) = ap
613−
630+-- | Convenience type synonym for the 'TimeMachine' used to manage 'StackWidget'
631+-- focus and offset states. The first parameter is the "focus previous" event and
632+-- the second parameter is a tuple of "focus next" and the total size.
633+type StackT t = TimeMachineT (Event t ()) (Event t (), Dynamic t Int)
634+
635+-- | A 'VtyWidget' that can be stacked automatically
636+newtype StackWidget t m a
637+ = StackWidget
638+ { unStackWidget ::
639+ StackT t
640+ (EventWriterT t ()
641+ (ReaderT (StackConfig, Event t ())
642+ (VtyWidget t m))) a
643+ }
644+ deriving
645+ ( Functor
646+ , Applicative
647+ , Monad
648+ , MonadSample t
649+ , MonadHold t
650+ , MonadFix
651+ , NotReady t
652+ , HasDisplaySize t
653+ )
654+
655+-- | Retrieve the 'Direction'/orientation of the current 'StackWidget'
656+askDirection :: MonadFix m => StackWidget t m Direction
657+askDirection = StackWidget $ asks $ _stackConfig_direction . fst
658+
659+-- | Retrieve the offset reported by the previous 'tile'
660+askOffset :: Monad m => StackWidget t m (Dynamic t Int)
661+askOffset = StackWidget $ snd <$> recvFromPast
662+
663+-- | Compute the remaining main-axis space available
664+askRemainingSpace :: (Reflex t, MonadFix m) => StackWidget t m (Dynamic t Int)
665+askRemainingSpace = do
666+ dir <- askDirection
667+ offset <- askOffset
668+ sz <- case dir of
669+ Direction_Column -> displayHeight
670+ Direction_Row -> displayWidth
671+ return $ sz - offset
672+
673+-- | A 'VtyWidget' and its actual main-axis size
674+type SizedWidget t m a = VtyWidget t m (Dynamic t Int, a)
675+
676+-- | Runs a 'StackWidget' with the provided configuration and initial offset
614677runStackWidget
615− :: (Reflex t, MonadFix m)
616− => Direction
678+ :: (MonadFix m, PostBuild t m)
679+ => StackConfig
617680 -> Dynamic t Int
618681 -> StackWidget t m a
619− -> VtyWidget t m (Dynamic t (Sum Int), a)
620−runStackWidget dir offset x = do
621− mkRegion <- case dir of
622− Direction_Column -> (\w sz -> DynRegion 0 offset w sz) <$> displayWidth
623− Direction_Row -> (\h sz -> DynRegion offset 0 sz h) <$> displayHeight
624− rec (a, h) <- pane (mkRegion h') (pure True) $ runDynamicWriterT $ runReaderT (unStackWidget x) dir
625− let h' = getSum <$> h
626− return (h, a)
627−
628−instance (MonadFix m, Reflex t) => Monad (StackWidget t m) where
629− w >>= g = StackWidget $ do
630− dir <- ask
631− (sz, r) <- lift $ lift $ runStackWidget dir 0 w
632− tellDyn sz
633− (sz', r') <- lift $ lift $ runStackWidget dir (getSum <$> sz) (g r)
634− tellDyn sz'
635− return r'
636− return x = StackWidget $ return x
682+ -> SizedWidget t m a
683+runStackWidget cfg offset x = do
684+ pb <- getPostBuild
685+ rec ((back, (fwd, sz), a), unfocus) <- runReaderT (runEventWriterT (runTimeMachineT (unStackWidget x) back (fwd <> pb, offset))) (cfg, unfocus)
686+ return (sz, a)
687+
688+-- | Turns a 'SizedWidget' into a 'StackWidget'. Wires up the focus-switching
689+-- and offset propagation.
690+tile
691+ :: (Reflex t, MonadHold t m, MonadFix m)
692+ => SizedWidget t m a
693+ -> StackWidget t m a
694+tile s = StackWidget $ do
695+ (focusTriggerP, offset) <- recvFromPast
696+ rec sendToPast focusBackward
697+ (cfg, unfocus) <- ask
698+ let bk = Set.difference (_stackConfig_focusPrevKey cfg) fk
699+ fk = _stackConfig_focusNextKey cfg
700+ focused <- holdDyn False $ leftmost
701+ [ True <$ (focusTriggerF <> focusTriggerP)
702+ , True <$ click
703+ , False <$ unfocus -- NB: unfocus must come after events that focus the current widget
704+ ]
705+ tellEvent $ mconcat
706+ [ () <$ click
707+ , () <$ keypress
708+ ]
709+ reg <- case _stackConfig_direction cfg of
710+ Direction_Column -> do
711+ w <- displayWidth
712+ return $ DynRegion 0 offset w sz
713+ Direction_Row -> do
714+ h <- displayHeight
715+ return $ DynRegion offset 0 sz h
716+ (click, keypress, (sz, r)) <- lift $ lift $ lift $ pane reg focused $ do
717+ e <- mouseDown V.BLeft
718+ ek <- keyCombos $ Set.union bk fk
719+ v <- s
720+ return (e, ek, v)
721+ let focusForward = () <$ ffilter (flip Set.member fk) keypress
722+ focusBackward = () <$ ffilter (flip Set.member bk) keypress
723+ focusTriggerF <- recvFromFuture
724+ sendToFuture (focusForward, sz + offset)
725+ return r
726+
727+-- | Configuration for a 'StackWidget'
728+data StackConfig = StackConfig
729+ { _stackConfig_direction :: Direction
730+ , _stackConfig_focusNextKey :: Set KeyCombo
731+ , _stackConfig_focusPrevKey :: Set KeyCombo
732+ }
637733
734+instance Default StackConfig where
735+ def = StackConfig
736+ { _stackConfig_direction = Direction_Column
737+ , _stackConfig_focusNextKey = Set.singleton (V.KChar '\t', [])
738+ , _stackConfig_focusPrevKey = Set.singleton (V.KBackTab, [])
739+ }
740+
741+-- | Runs a 'StackWidget' with the provided configuration
638742stack
639− :: (Reflex t, MonadFix m)
640− => Direction
743+ :: (MonadFix m, PostBuild t m)
744+ => StackConfig
641745 -> StackWidget t m a
642746 -> VtyWidget t m a
643−stack dir w = fmap snd $ runStackWidget dir 0 w
747+stack cfg w = fmap snd $ runStackWidget cfg 0 w
644748
749+-- | Runs a vertically-oriented 'StackWidget' (i.e., a column)
645750col
646− :: (Reflex t, MonadFix m)
751+ :: (MonadFix m, PostBuild t m)
647752 => StackWidget t m a
648753 -> VtyWidget t m a
649−col = stack Direction_Column
754+col = stack def
650755
756+-- | Runs a horizontally-oriented 'StackWidget' (i.e., a row)
651757row
652− :: (Reflex t, MonadFix m)
758+ :: (MonadFix m, PostBuild t m)
653759 => StackWidget t m a
654760 -> VtyWidget t m a
655−row = stack Direction_Row
761+row = stack $ def { _stackConfig_direction = Direction_Row }
656762
657−sized
658− :: (Reflex t, MonadFix m)
763+-- | A 'tile' of a fixed size
764+fixed
765+ :: (Reflex t, MonadFix m, MonadHold t m)
659766 => Dynamic t Int
660767 -> VtyWidget t m a
661768 -> StackWidget t m a
662−sized sz w = StackWidget $ do
663− tellDyn $ Sum <$> sz
664− lift $ lift w
769+fixed sz w = tile $ (sz,) <$> w
770+
771+-- | A 'tile' that takes up the given fraction of the remaining
772+-- main-axis space
773+fraction
774+ :: (Reflex t, MonadFix m, MonadHold t m)
775+ => Dynamic t Rational
776+ -> VtyWidget t m a
777+ -> StackWidget t m a
778+fraction n w = do
779+ s <- askRemainingSpace
780+ let sz = fmap round $ n * fmap fromIntegral s
781+ fixed sz w
782+
783+-- | A 'tile' that takes up all of the remaining main-axis space
784+remaining
785+ :: (Reflex t, MonadHold t m, MonadFix m)
786+ => VtyWidget t m a
787+ -> StackWidget t m a
788+remaining w = do
789+ s <- askRemainingSpace
790+ fixed s w