@@ -5,71 +5,17 @@ Description: Basic set of widgets and building blocks for reflex-vty application
55{-# Language UndecidableInstances #-}
66
77module Reflex.Vty.Widget where
8− -- ( VtyWidgetCtx(..)
9− -- , VtyWidget(..)
10− -- , VtyWidgetOut(..)
11− -- , ImageWriter(..)
12− -- , runVtyWidget
13− -- , mainWidget
14− -- , mainWidgetWithHandle
15− -- , HasDisplayRegion(..)
16− -- , HasFocus(..)
17− -- , HasVtyInput(..)
18− -- , HasVtyWidgetCtx(..)
19− -- , Region(..)
20− -- , regionSize
21− -- , regionBlankImage
22− -- , Drag(..)
23− -- , drag
24− -- , MouseDown(..)
25− -- , MouseUp(..)
26− -- , mouseDown
27− -- , mouseUp
28− -- , ScrollDirection(..)
29− -- , mouseScroll
30− -- , pane
31− -- , splitV
32− -- , splitH
33− -- , splitVDrag
34− -- , boxTitle
35− -- , box
36− -- , boxStatic
37− -- , RichTextConfig(..)
38− -- , richText
39− -- , text
40− -- , scrollableText
41− -- , display
42− -- , BoxStyle(..)
43− -- , hyphenBoxStyle
44− -- , singleBoxStyle
45− -- , roundedBoxStyle
46− -- , thickBoxStyle
47− -- , doubleBoxStyle
48− -- , fill
49− -- , hRule
50− -- , filterKeys
51− -- , KeyCombo
52− -- , key
53− -- , keys
54− -- , keyCombo
55− -- , keyCombos
56− -- , blank
57− -- ) where
588
599import Control.Applicative (liftA2)
6010import Control.Monad.Fix (MonadFix)
6111import Control.Monad.IO.Class (MonadIO)
6212import Control.Monad.Morph
6313import Control.Monad.NodeId
64−import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
14+import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
6515import Control.Monad.Ref
6616import Control.Monad.Trans (MonadTrans, lift)
67−import Data.Default (Default(..))
6817import Data.Set (Set)
6918import qualified Data.Set as Set
70−import Data.Text (Text)
71−import qualified Data.Text as T
72−import qualified Data.Text.Zipper as TZ
7319import Graphics.Vty (Image)
7420import qualified Graphics.Vty as V
7521import Reflex
@@ -77,80 +23,9 @@ import Reflex.Class ()
7723import Reflex.Host.Class (MonadReflexCreateTrigger)
7824import Reflex.Vty.Host
7925
80−-- | The context within which a 'VtyWidget' runs
81−data VtyWidgetCtx t = VtyWidgetCtx
82− { _vtyWidgetCtx_focus :: Dynamic t Bool
83− -- ^ Whether the widget should behave as if it has focus for keyboard input.
84− }
26+-- * Running a vty application
8527
86−-- | The output of a 'VtyWidget'
87−data VtyWidgetOut t = VtyWidgetOut
88− { _vtyWidgetOut_shutdown :: Event t ()
89− }
90−
91−instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where
92− runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'
93− traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $
94− traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
95− traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do
96− traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'
97− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do
98− traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'
99−
100−-- | A widget that can read its context and produce image output
101−newtype VtyWidget t m a = VtyWidget
102− { unVtyWidget ::
103− ReaderT (VtyWidgetCtx t)
104− (ReaderT (Event t VtyEvent) m) a
105− } deriving
106− ( Functor
107− , Applicative
108− , Monad
109− , MonadSample t
110− , MonadHold t
111− , MonadFix
112− , MonadIO
113− , MonadRef
114− )
115−
116−deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (VtyWidget t m)
117−deriving instance NotReady t m => NotReady t (VtyWidget t m)
118−deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
119−deriving instance PostBuild t m => PostBuild t (VtyWidget t m)
120−deriving instance TriggerEvent t m => TriggerEvent t (VtyWidget t m)
121−instance HasImageWriter t m => HasImageWriter t (VtyWidget t m)
122−instance HasDisplayRegion t m => HasDisplayRegion t (VtyWidget t m)
123−
124−instance MonadTrans (VtyWidget t) where
125− lift f = VtyWidget $ lift $ lift f
126−
127−instance MFunctor (VtyWidget t) where
128− hoist f = VtyWidget . hoist (hoist f) . unVtyWidget
129−
130−instance MonadNodeId m => MonadNodeId (VtyWidget t m)
131−
132−
133−-- | A reader-like class for the vty widget context. Allows actions to be run in a sub-context.
134−class HasVtyWidgetCtx t m | m -> t where
135− askCtx :: m (VtyWidgetCtx t)
136− default askCtx :: (f m' ~ m, Monad m', MonadTrans f, HasVtyWidgetCtx t m') => m (VtyWidgetCtx t)
137− askCtx = lift askCtx
138− localCtx :: (VtyWidgetCtx t -> VtyWidgetCtx t) -> m a -> m a
139−
140−instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where
141− askCtx = VtyWidget $ ask
142− localCtx f (VtyWidget x) = VtyWidget $ local f x
143−
144−-- | Runs a 'VtyWidget' with a given context
145−runVtyWidget
146− :: (Reflex t, MonadNodeId m)
147− => Event t VtyEvent
148− -> VtyWidgetCtx t
149− -> VtyWidget t m a
150− -> m a
151−runVtyWidget e ctx w = runReaderT (runReaderT (unVtyWidget w) ctx) e
152−
153−-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context
28+-- | Sets up the top-level context for a vty widget and runs it with that context
15429mainWidgetWithHandle
15530 :: V.Vty
15631 -> (forall t m.
@@ -158,7 +33,9 @@ mainWidgetWithHandle
15833 , HasImageWriter t m
15934 , MonadNodeId m
16035 , HasDisplayRegion t m
161− ) => VtyWidget t m (Event t ()))
36+ , HasFocusReader t m
37+ , HasInput t m
38+ ) => m (Event t ()))
16239 -> IO ()
16340mainWidgetWithHandle vty child =
16441 runVtyAppWithHandle vty $ \dr0 inp -> do
@@ -168,13 +45,10 @@ mainWidgetWithHandle vty child =
16845 let inp' = fforMaybe inp $ \case
16946 V.EvResize {} -> Nothing
17047 x -> Just x
171− let ctx = VtyWidgetCtx
172− { _vtyWidgetCtx_focus = constDyn True
173− }
174− (shutdown, images) <- runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
48+ (shutdown, images) <- runFocusReader (pure True) $ runDisplayRegion (fmap (\(w, h) -> Region 0 0 w h) size) $
17549 runImageWriter $
17650 runNodeIdT $
177− runVtyWidget inp' ctx $ do
51+ runInput inp' $ do
17852 tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
17953 child
18054 return $ VtyResult
@@ -182,6 +56,11 @@ mainWidgetWithHandle vty child =
18256 , _vtyResult_shutdown = shutdown
18357 }
18458
59+-- | The output of a vty widget
60+data VtyWidgetOut t = VtyWidgetOut
61+ { _vtyWidgetOut_shutdown :: Event t ()
62+ }
63+
18564-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
18665mainWidget
18766 :: (forall t m.
@@ -189,12 +68,167 @@ mainWidget
18968 , HasImageWriter t m
19069 , MonadNodeId m
19170 , HasDisplayRegion t m
192− ) => VtyWidget t m (Event t ()))
71+ , HasFocusReader t m
72+ , HasInput t m
73+ ) => m (Event t ()))
19374 -> IO ()
19475mainWidget child = do
19576 vty <- getDefaultVty
19677 mainWidgetWithHandle vty child
19778
79+-- * Input Events
80+
81+-- | A class for things that can receive vty events as input
82+class HasInput t m | m -> t where
83+ input :: m (Event t VtyEvent)
84+ default input :: (f m' ~ m, Monad m', MonadTrans f, HasInput t m') => m (Event t VtyEvent)
85+ input = lift input
86+ -- | User input events that the widget's parent chooses to share. These will generally
87+ -- be filtered for relevance.
88+ localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
89+ default localInput :: (f m' ~ m, Monad m', MFunctor f, HasInput t m') => (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
90+ localInput f = hoist (localInput f)
91+
92+instance (Reflex t, Monad m) => HasInput t (Input t m) where
93+ input = Input ask
94+ localInput f (Input m) = Input $ local f m
95+
96+-- | A widget that can receive input events. See 'Graphics.Vty.Event'
97+newtype Input t m a = Input
98+ { unInput :: ReaderT (Event t VtyEvent) m a
99+ } deriving
100+ ( Functor
101+ , Applicative
102+ , Monad
103+ , MonadSample t
104+ , MonadHold t
105+ , MonadFix
106+ , MonadIO
107+ , MonadRef
108+ )
109+
110+instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (Input t m) where
111+ runWithReplace a0 a' = Input $ runWithReplace (unInput a0) $ fmap unInput a'
112+ traverseIntMapWithKeyWithAdjust f dm0 dm' = Input $
113+ traverseIntMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
114+ traverseDMapWithKeyWithAdjust f dm0 dm' = Input $ do
115+ traverseDMapWithKeyWithAdjust (\k v -> unInput (f k v)) dm0 dm'
116+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = Input $ do
117+ traverseDMapWithKeyWithAdjustWithMove (\k v -> unInput (f k v)) dm0 dm'
118+
119+deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Input t m)
120+deriving instance NotReady t m => NotReady t (Input t m)
121+deriving instance PerformEvent t m => PerformEvent t (Input t m)
122+deriving instance PostBuild t m => PostBuild t (Input t m)
123+deriving instance TriggerEvent t m => TriggerEvent t (Input t m)
124+instance HasImageWriter t m => HasImageWriter t (Input t m)
125+instance HasDisplayRegion t m => HasDisplayRegion t (Input t m)
126+instance HasFocusReader t m => HasFocusReader t (Input t m)
127+
128+instance MonadTrans (Input t) where
129+ lift f = Input $ lift f
130+
131+instance MFunctor (Input t) where
132+ hoist f = Input . hoist f . unInput
133+
134+instance MonadNodeId m => MonadNodeId (Input t m)
135+
136+-- | Runs an 'Input' with a given context
137+runInput
138+ :: Reflex t
139+ => Event t VtyEvent
140+ -> Input t m a
141+ -> m a
142+runInput e w = runReaderT (unInput w) e
143+
144+-- ** Filtering input
145+
146+-- | Type synonym for a key and modifier combination
147+type KeyCombo = (V.Key, [V.Modifier])
148+
149+-- | Emits an event that fires on a particular key press (without modifiers)
150+key :: (Monad m, Reflex t, HasInput t m) => V.Key -> m (Event t KeyCombo)
151+key = keyCombos . Set.singleton . (,[])
152+
153+-- | Emits an event that fires on particular key presses (without modifiers)
154+keys :: (Monad m, Reflex t, HasInput t m) => [V.Key] -> m (Event t KeyCombo)
155+keys = keyCombos . Set.fromList . fmap (,[])
156+
157+-- | Emit an event that fires whenever the provided key combination occurs
158+keyCombo
159+ :: (Reflex t, Monad m, HasInput t m)
160+ => KeyCombo
161+ -> m (Event t KeyCombo)
162+keyCombo = keyCombos . Set.singleton
163+
164+-- | Emit an event that fires whenever any of the provided key combinations occur
165+keyCombos
166+ :: (Reflex t, Monad m, HasInput t m)
167+ => Set KeyCombo
168+ -> m (Event t KeyCombo)
169+keyCombos ks = do
170+ i <- input
171+ return $ fforMaybe i $ \case
172+ V.EvKey k m -> if Set.member (k, m) ks
173+ then Just (k, m)
174+ else Nothing
175+ _ -> Nothing
176+
177+-- | Filter the keyboard input that a child widget may receive
178+filterKeys :: (Reflex t, HasInput t m) => (KeyCombo -> Bool) -> m a -> m a
179+filterKeys f x = localInput (ffilter (\case
180+ V.EvKey k mods -> f (k, mods)
181+ _ -> True)) x
182+
183+-- | Filter mouse input events based on whether they target a particular region
184+-- and translate them to the internal coordinate system of that region.
185+--
186+-- NB: Non-mouse events are passed through unfiltered and unchanged
187+mouseInRegion :: Region -> VtyEvent -> Maybe VtyEvent
188+mouseInRegion (Region l t w h) e = case e of
189+ V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
190+ V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
191+ _ -> Just e
192+ where
193+ mouse con x y
194+ | or [ x < l
195+ , y < t
196+ , x >= l + w
197+ , y >= t + h ] = Nothing
198+ | otherwise =
199+ Just (con (x - l) (y - t))
200+
201+-- | Filter mouse input outside the current display region and
202+-- all input if the region is not focused
203+inputInFocusedRegion
204+ :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
205+ => m (Event t VtyEvent)
206+inputInFocusedRegion = do
207+ inp <- input
208+ reg <- current <$> askRegion
209+ f <- current <$> focus
210+ pure $ gate f $ fmapMaybe id $ attachWith mouseInRegion reg inp
211+
212+-- * Getting and setting the display region
213+
214+-- | A chunk of the display area
215+data Region = Region
216+ { _region_left :: Int
217+ , _region_top :: Int
218+ , _region_width :: Int
219+ , _region_height :: Int
220+ }
221+ deriving (Show, Read, Eq, Ord)
222+
223+-- | The width and height of a 'Region'
224+regionSize :: Region -> (Int, Int)
225+regionSize (Region _ _ w h) = (w, h)
226+
227+-- | Produces an 'Image' that fills a region with space characters
228+regionBlankImage :: Region -> Image
229+regionBlankImage r@(Region _ _ width height) =
230+ withinImage r $ V.charFill V.defAttr ' ' width height
231+
198232-- | A class for things that know their own display size dimensions
199233class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
200234 -- | Retrieve the display region
@@ -206,9 +240,11 @@ class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
206240 default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a
207241 localRegion f = hoist (localRegion f)
208242
243+-- | Retrieve the display width
209244displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
210245displayWidth = fmap _region_width <$> askRegion
211246
247+-- | Retrieve the display height
212248displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)
213249displayHeight = fmap _region_height <$> askRegion
214250
@@ -218,7 +254,9 @@ instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)
218254instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)
219255instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)
220256
221−newtype DisplayRegion t m a = DisplayRegion { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
257+-- | A widget that has access to a particular region of the vty display
258+newtype DisplayRegion t m a = DisplayRegion
259+ { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
222260 deriving
223261 ( Functor
224262 , Applicative
@@ -240,6 +278,7 @@ deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
240278deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
241279deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
242280instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
281+instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)
243282
244283instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
245284 runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e
@@ -247,7 +286,6 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayReg
247286 traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
248287 traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
249288
250−
251289instance MonadTrans (DisplayRegion t) where
252290 lift = DisplayRegion . lift
253291
@@ -256,6 +294,7 @@ instance MFunctor (DisplayRegion t) where
256294
257295instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
258296
297+-- | Run a 'DisplayRegion' action with a given 'Region'
259298runDisplayRegion
260299 :: (Reflex t, Monad m)
261300 => Dynamic t Region
@@ -263,33 +302,71 @@ runDisplayRegion
263302 -> m a
264303runDisplayRegion r = flip runReaderT r . unDisplayRegion
265304
266−-- | A class for things that can receive vty events as input
267−class HasVtyInput t m | m -> t where
268− input :: m (Event t VtyEvent)
269− default input :: (f m' ~ m, Monad m', MonadTrans f, HasVtyInput t m') => m (Event t VtyEvent)
270− input = lift input
271− -- | User input events that the widget's parent chooses to share. These will generally
272− -- be filtered for relevance.
273− localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
274−
275−-- | Filter the keyboard input that a child widget may receive
276−filterKeys :: (Reflex t, HasVtyInput t m) => (KeyCombo -> Bool) -> m a -> m a
277−filterKeys f x = localInput (ffilter (\case
278− V.EvKey k mods -> f (k, mods)
279− _ -> True)) x
280−
281−instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
282− input = VtyWidget . lift $ ask
283− localInput f (VtyWidget m) = VtyWidget $ hoist (local f) m
305+-- * Getting focus state
284306
285307-- | A class for things that can dynamically gain and lose focus
286−class HasFocus t m | m -> t where
308+class (Reflex t, Monad m) => HasFocusReader t m | m -> t where
287309 focus :: m (Dynamic t Bool)
288− default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocus t m') => m (Dynamic t Bool)
310+ default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocusReader t m') => m (Dynamic t Bool)
289311 focus = lift focus
312+ localFocus :: (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
313+ default localFocus :: (f m' ~ m, Monad m', MFunctor f, HasFocusReader t m') => (Dynamic t Bool -> Dynamic t Bool) -> m a -> m a
314+ localFocus f = hoist (localFocus f)
315+
316+instance HasFocusReader t m => HasFocusReader t (ReaderT x m)
317+instance HasFocusReader t m => HasFocusReader t (BehaviorWriterT t x m)
318+instance HasFocusReader t m => HasFocusReader t (DynamicWriterT t x m)
319+instance HasFocusReader t m => HasFocusReader t (EventWriterT t x m)
320+instance HasFocusReader t m => HasFocusReader t (NodeIdT m)
321+
322+-- | A widget that has access to information about whether it is focused
323+newtype FocusReader t m a = FocusReader
324+ { unFocusReader :: ReaderT (Dynamic t Bool) m a }
325+ deriving
326+ ( Functor
327+ , Applicative
328+ , Monad
329+ , MonadFix
330+ , MonadHold t
331+ , MonadIO
332+ , MonadRef
333+ , MonadSample t
334+ )
335+
336+instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where
337+ focus = FocusReader ask
338+ localFocus f = FocusReader . local f . unFocusReader
339+
340+deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (FocusReader t m)
341+deriving instance NotReady t m => NotReady t (FocusReader t m)
342+deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)
343+deriving instance PostBuild t m => PostBuild t (FocusReader t m)
344+deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)
345+instance HasImageWriter t m => HasImageWriter t (FocusReader t m)
346+
347+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where
348+ runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e
349+ traverseIntMapWithKeyWithAdjust f m e = FocusReader $ traverseIntMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
350+ traverseDMapWithKeyWithAdjust f m e = FocusReader $ traverseDMapWithKeyWithAdjust (\k v -> unFocusReader $ f k v) m e
351+ traverseDMapWithKeyWithAdjustWithMove f m e = FocusReader $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocusReader $ f k v) m e
290352
291−instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
292− focus = VtyWidget $ asks _vtyWidgetCtx_focus
353+instance MonadTrans (FocusReader t) where
354+ lift = FocusReader . lift
355+
356+instance MFunctor (FocusReader t) where
357+ hoist f = FocusReader . hoist f . unFocusReader
358+
359+instance MonadNodeId m => MonadNodeId (FocusReader t m)
360+
361+-- | Run a 'FocusReader' action with the given focus value
362+runFocusReader
363+ :: (Reflex t, Monad m)
364+ => Dynamic t Bool
365+ -> FocusReader t m a
366+ -> m a
367+runFocusReader b = flip runReaderT b . unFocusReader
368+
369+-- * "Image" output
293370
294371-- | A class for widgets that can produce images to draw to the display
295372class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
@@ -302,7 +379,9 @@ class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
302379 default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
303380 mapImages f = hoist (mapImages f)
304381
305−newtype ImageWriter t m a = ImageWriter { unImageWriter :: BehaviorWriterT t [Image] m a }
382+-- | A widget that can produce images to draw onto the display
383+newtype ImageWriter t m a = ImageWriter
384+ { unImageWriter :: BehaviorWriterT t [Image] m a }
306385 deriving
307386 ( Functor
308387 , Applicative
@@ -345,30 +424,16 @@ instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
345424 pure a
346425
347426instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
427+instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
348428
429+-- | Run a widget that can produce images
349430runImageWriter
350431 :: (Reflex t, Monad m)
351432 => ImageWriter t m a
352433 -> m (a, Behavior t [Image])
353434runImageWriter = runBehaviorWriterT . unImageWriter
354435
355−-- | A chunk of the display area
356−data Region = Region
357− { _region_left :: Int
358− , _region_top :: Int
359− , _region_width :: Int
360− , _region_height :: Int
361− }
362− deriving (Show, Read, Eq, Ord)
363−
364−-- | The width and height of a 'Region'
365−regionSize :: Region -> (Int, Int)
366−regionSize (Region _ _ w h) = (w, h)
367−
368−-- | Produces an 'Image' that fills a region with space characters
369−regionBlankImage :: Region -> Image
370−regionBlankImage r@(Region _ _ width height) =
371− withinImage r $ V.charFill V.defAttr ' ' width height
436+-- ** Manipulating images
372437
373438-- | Translates and crops an 'Image' so that it is contained by
374439-- the given 'Region'.
@@ -380,7 +445,17 @@ withinImage (Region left top width height)
380445 | width < 0 || height < 0 = withinImage (Region left top 0 0)
381446 | otherwise = V.translate left top . V.crop width height
382447
383−-- | Low-level widget combinator that runs a child 'VtyWidget' within
448+-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.
449+imagesInRegion
450+ :: Reflex t
451+ => Behavior t Region
452+ -> Behavior t [Image]
453+ -> Behavior t [Image]
454+imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
455+
456+-- * Running sub-widgets
457+
458+-- | Low-level widget combinator that runs a child 'Input' within
384459-- a given region and context. This widget filters and modifies the input
385460-- that the child widget receives such that:
386461-- * unfocused widgets receive no key events
@@ -388,435 +463,15 @@ withinImage (Region left top width height)
388463-- * mouse inputs inside the region have their coordinates translated such
389464-- that (0,0) is the top-left corner of the region
390465pane
391− :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasVtyInput t m, HasImageWriter t m, HasDisplayRegion t m)
466+ :: (Reflex t, Monad m, MonadNodeId m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
392467 => Dynamic t Region
393468 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
394469 -> m a
395470 -> m a
396−pane dr foc child = do
397− let reg = current dr
398− let subContext ctx = VtyWidgetCtx
399− { _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
400− }
401− inputFilter = fmapMaybe id .
402− attachWith (\(r,f) e -> filterInput r f e)
403− (liftA2 (,) reg (current foc))
404− let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg
405− localRegion (const dr) $ mapImages imagesWithinRegion $ localInput inputFilter $ localCtx subContext child
406− where
407− filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
408− filterInput (Region l t w h) focused e = case e of
409− V.EvKey _ _ | not focused -> Nothing
410− V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
411− V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
412− _ -> Just e
413− where
414− mouse con x y
415− | or [ x < l
416− , y < t
417− , x >= l + w
418− , y >= t + h ] = Nothing
419− | otherwise =
420− Just (con (x - l) (y - t))
421−
422−-- | Information about a drag operation
423−data Drag = Drag
424− { _drag_from :: (Int, Int) -- ^ Where the drag began
425− , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
426− , _drag_button :: V.Button -- ^ Which mouse button is dragging
427− , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
428− , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
429− }
430− deriving (Eq, Ord, Show)
431−
432−-- | Converts raw vty mouse drag events into an event stream of 'Drag's
433−drag
434− :: (Reflex t, MonadFix m, MonadHold t m, HasVtyInput t m)
435− => V.Button
436− -> m (Event t Drag)
437−drag btn = do
438− inp <- input
439− let f :: Maybe Drag -> V.Event -> Maybe Drag
440− f Nothing = \case
441− V.EvMouseDown x y btn' mods
442− | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
443− | otherwise -> Nothing
444− _ -> Nothing
445− f (Just (Drag from _ _ mods end)) = \case
446− V.EvMouseDown x y btn' mods'
447− | end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
448− | btn == btn' -> Just $ Drag from (x,y) btn mods' False
449− | otherwise -> Nothing -- Ignore other buttons.
450− V.EvMouseUp x y (Just btn')
451− | end -> Nothing
452− | btn == btn' -> Just $ Drag from (x,y) btn mods True
453− | otherwise -> Nothing
454− V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
455− -- assume it's the right one.
456− | end -> Nothing
457− | otherwise -> Just $ Drag from (x,y) btn mods True
458− _ -> Nothing
459− rec let newDrag = attachWithMaybe f (current dragD) inp
460− dragD <- holdDyn Nothing $ Just <$> newDrag
461− return (fmapMaybe id $ updated dragD)
462−
463−-- | Mouse down events for a particular mouse button
464−mouseDown
465− :: (Reflex t, Monad m, HasVtyInput t m)
466− => V.Button
467− -> m (Event t MouseDown)
468−mouseDown btn = do
469− i <- input
470− return $ fforMaybe i $ \case
471− V.EvMouseDown x y btn' mods -> if btn == btn'
472− then Just $ MouseDown btn' (x, y) mods
473− else Nothing
474− _ -> Nothing
475−
476−-- | Mouse up events for a particular mouse button
477−mouseUp
478− :: (Reflex t, Monad m, HasVtyInput t m)
479− => m (Event t MouseUp)
480−mouseUp = do
481− i <- input
482− return $ fforMaybe i $ \case
483− V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
484− _ -> Nothing
485−
486−-- | Information about a mouse down event
487−data MouseDown = MouseDown
488− { _mouseDown_button :: V.Button
489− , _mouseDown_coordinates :: (Int, Int)
490− , _mouseDown_modifiers :: [V.Modifier]
491− }
492− deriving (Eq, Ord, Show)
493−
494−-- | Information about a mouse up event
495−data MouseUp = MouseUp
496− { _mouseUp_button :: Maybe V.Button
497− , _mouseUp_coordinates :: (Int, Int)
498− }
499− deriving (Eq, Ord, Show)
500−
501−-- | Mouse scroll direction
502−data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
503− deriving (Eq, Ord, Show)
504−
505−-- | Produce an event that fires when the mouse wheel is scrolled
506−mouseScroll
507− :: (Reflex t, Monad m, HasVtyInput t m)
508− => m (Event t ScrollDirection)
509−mouseScroll = do
510− up <- mouseDown V.BScrollUp
511− down <- mouseDown V.BScrollDown
512− return $ leftmost
513− [ ScrollDirection_Up <$ up
514− , ScrollDirection_Down <$ down
515− ]
516−
517−-- | Type synonym for a key and modifier combination
518−type KeyCombo = (V.Key, [V.Modifier])
519−
520−-- | Emits an event that fires on a particular key press (without modifiers)
521−key :: (Monad m, Reflex t, HasVtyInput t m) => V.Key -> m (Event t KeyCombo)
522−key = keyCombos . Set.singleton . (,[])
523−
524−-- | Emits an event that fires on particular key presses (without modifiers)
525−keys :: (Monad m, Reflex t, HasVtyInput t m) => [V.Key] -> m (Event t KeyCombo)
526−keys = keyCombos . Set.fromList . fmap (,[])
527−
528−-- | Emit an event that fires whenever the provided key combination occurs
529−keyCombo
530− :: (Reflex t, Monad m, HasVtyInput t m)
531− => KeyCombo
532− -> m (Event t KeyCombo)
533−keyCombo = keyCombos . Set.singleton
534−
535−-- | Emit an event that fires whenever any of the provided key combinations occur
536−keyCombos
537− :: (Reflex t, Monad m, HasVtyInput t m)
538− => Set KeyCombo
539− -> m (Event t KeyCombo)
540−keyCombos ks = do
541− i <- input
542− return $ fforMaybe i $ \case
543− V.EvKey k m -> if Set.member (k, m) ks
544− then Just (k, m)
545− else Nothing
546− _ -> Nothing
547−
548−-- | A plain split of the available space into vertically stacked panes.
549−-- No visual separator is built in here.
550−splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplayRegion t m, HasVtyInput t m, HasImageWriter t m)
551− => Dynamic t (Int -> Int)
552− -- ^ Function used to determine size of first pane based on available size
553− -> Dynamic t (Bool, Bool)
554− -- ^ How to focus the two sub-panes, given that we are focused.
555− -> m a
556− -- ^ Widget for first pane
557− -> m b
558− -- ^ Widget for second pane
559− -> m (a,b)
560−splitV sizeFunD focD wA wB = do
561− dw <- displayWidth
562− dh <- displayHeight
563− let regA = Region 0 0 <$> dw <*> (sizeFunD <*> dh)
564− regB = Region 0 <$> (_region_height <$> regA) <*> dw <*> liftA2 (-) dh (_region_height <$> regA)
565− ra <- pane regA (fst <$> focD) wA
566− rb <- pane regB (snd <$> focD) wB
567− return (ra,rb)
568−
569−-- | A plain split of the available space into horizontally stacked panes.
570−-- No visual separator is built in here.
571−splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplayRegion t m, HasVtyWidgetCtx t m, HasVtyInput t m, HasImageWriter t m)
572− => Dynamic t (Int -> Int)
573− -- ^ Function used to determine size of first pane based on available size
574− -> Dynamic t (Bool, Bool)
575− -- ^ How to focus the two sub-panes, given that we are focused.
576− -> m a
577− -- ^ Widget for first pane
578− -> m b
579− -- ^ Widget for second pane
580− -> m (a,b)
581−splitH sizeFunD focD wA wB = do
582− dw <- displayWidth
583− dh <- displayHeight
584− let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh
585− regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh
586− liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
587−
588−-- | A split of the available space into two parts with a draggable separator.
589−-- Starts with half the space allocated to each, and the first pane has focus.
590−-- Clicking in a pane switches focus.
591−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m, HasDisplayRegion t m, HasVtyInput t m, HasVtyWidgetCtx t m, HasImageWriter t m)
592− => m ()
593− -> m a
594− -> m b
595− -> m (a,b)
596−splitVDrag wS wA wB = do
597− dh <- displayHeight
598− dw <- displayWidth
599− h0 <- sample $ current dh -- TODO
600− dragE <- drag V.BLeft
601− let splitter0 = h0 `div` 2
602− rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
603− splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
604− splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
605− fromIntegral x / max 1 (fromIntegral h)
606− let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
607− \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
608− if splitterY == fromY then Just (toY, end) else Nothing
609− regA = Region 0 0 <$> dw <*> splitterPos
610− regS = Region 0 <$> splitterPos <*> dw <*> 1
611− regB = Region 0 <$> (splitterPos + 1) <*> dw <*> (dh - splitterPos - 1)
612− resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
613− \(frac, h) -> round (frac * fromIntegral h)
614− focA <- holdDyn True $ leftmost
615− [ True <$ mA
616− , False <$ mB
617− ]
618− (mA, rA) <- pane regA focA $ withMouseDown wA
619− pane regS (pure False) wS
620− (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
621− return (rA, rB)
622− where
623− withMouseDown x = do
624− m <- mouseDown V.BLeft
625− x' <- x
626− return (m, x')
627−
628−-- | Fill the background with a particular character.
629−fill :: (HasDisplayRegion t m, HasImageWriter t m) => Behavior t Char -> m ()
630−fill bc = do
631− dw <- displayWidth
632− dh <- displayHeight
633− let fillImg =
634− (\w h c -> [V.charFill V.defAttr c w h])
635− <$> current dw
636− <*> current dh
637− <*> bc
638− tellImages fillImg
639−
640−-- | Fill the background with the bottom box style
641−hRule :: (HasDisplayRegion t m, HasImageWriter t m) => BoxStyle -> m ()
642−hRule boxStyle = fill $ pure (_boxStyle_s boxStyle)
643−
644−-- | Defines a set of symbols to use to draw the outlines of boxes
645−-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character
646−data BoxStyle = BoxStyle
647− { _boxStyle_nw :: Char
648− , _boxStyle_n :: Char
649− , _boxStyle_ne :: Char
650− , _boxStyle_e :: Char
651− , _boxStyle_se :: Char
652− , _boxStyle_s :: Char
653− , _boxStyle_sw :: Char
654− , _boxStyle_w :: Char
655− }
656−
657−instance Default BoxStyle where
658− def = singleBoxStyle
659−
660−-- | A box style that uses hyphens and pipe characters. Doesn't handle
661−-- corners very well.
662−hyphenBoxStyle :: BoxStyle
663−hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
664−
665−-- | A single line box style
666−singleBoxStyle :: BoxStyle
667−singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
668−
669−-- | A thick single line box style
670−thickBoxStyle :: BoxStyle
671−thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
672−
673−-- | A double line box style
674−doubleBoxStyle :: BoxStyle
675−doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
676−
677−-- | A single line box style with rounded corners
678−roundedBoxStyle :: BoxStyle
679−roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
680−
681−-- | Draws a titled box in the provided style and a child widget inside of that box
682−boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
683− => Behavior t BoxStyle
684− -> Behavior t Text
685− -> m a
686− -> m a
687−boxTitle boxStyle title child = do
688− dh <- displayHeight
689− dw <- displayWidth
690− let boxReg = Region 0 0 <$> dw <*> dh
691− innerReg = Region 1 1 <$> (subtract 2 <$> dw) <*> (subtract 2 <$> dh)
692− tellImages (boxImages <$> title <*> boxStyle <*> current boxReg)
693− tellImages (fmap (\r -> [regionBlankImage r]) (current innerReg))
694− pane innerReg (pure True) child
695− where
696− boxImages :: Text -> BoxStyle -> Region -> [Image]
697− boxImages title' style (Region left top width height) =
698− let right = left + width - 1
699− bottom = top + height - 1
700− sides =
701− [ withinImage (Region (left + 1) top (width - 2) 1) $
702− V.text' V.defAttr $
703− hPadText title' (_boxStyle_n style) (width - 2)
704− , withinImage (Region right (top + 1) 1 (height - 2)) $
705− V.charFill V.defAttr (_boxStyle_e style) 1 (height - 2)
706− , withinImage (Region (left + 1) bottom (width - 2) 1) $
707− V.charFill V.defAttr (_boxStyle_s style) (width - 2) 1
708− , withinImage (Region left (top + 1) 1 (height - 2)) $
709− V.charFill V.defAttr (_boxStyle_w style) 1 (height - 2)
710− ]
711− corners =
712− [ withinImage (Region left top 1 1) $
713− V.char V.defAttr (_boxStyle_nw style)
714− , withinImage (Region right top 1 1) $
715− V.char V.defAttr (_boxStyle_ne style)
716− , withinImage (Region right bottom 1 1) $
717− V.char V.defAttr (_boxStyle_se style)
718− , withinImage (Region left bottom 1 1) $
719− V.char V.defAttr (_boxStyle_sw style)
720− ]
721− in sides ++ if width > 1 && height > 1 then corners else []
722− hPadText :: T.Text -> Char -> Int -> T.Text
723− hPadText t c l = if lt >= l
724− then t
725− else left <> t <> right
726− where
727− lt = T.length t
728− delta = l - lt
729− mkHalf n = T.replicate (n `div` 2) (T.singleton c)
730− left = mkHalf $ delta + 1
731− right = mkHalf delta
732−
733−-- | A box without a title
734−box :: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
735− => Behavior t BoxStyle
736− -> m a
737− -> m a
738−box boxStyle = boxTitle boxStyle mempty
739−
740−-- | A box whose style is static
741−boxStatic
742− :: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
743− => BoxStyle
744− -> m a
745− -> m a
746−boxStatic = box . pure
747−
748−-- | Configuration options for displaying "rich" text
749−data RichTextConfig t = RichTextConfig
750− { _richTextConfig_attributes :: Behavior t V.Attr
751− }
752−
753−instance Reflex t => Default (RichTextConfig t) where
754− def = RichTextConfig $ pure V.defAttr
755−
756−-- | A widget that displays text with custom time-varying attributes
757−richText
758− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
759− => RichTextConfig t
760− -> Behavior t Text
761− -> m ()
762−richText cfg t = do
763− dw <- displayWidth
764− let img = (\w a s -> [wrapText w a s])
765− <$> current dw
766− <*> _richTextConfig_attributes cfg
767− <*> t
768− tellImages img
769− where
770− wrapText maxWidth attrs = V.vertCat
771− . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
772− . T.split (=='\n')
773−
774−-- | Renders text, wrapped to the container width
775−text
776− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
777− => Behavior t Text
778− -> m ()
779−text = richText def
780−
781−-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
782−-- that are hidden)
783−scrollableText
784− :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasVtyInput t m, HasImageWriter t m)
785− => Event t Int
786− -- ^ Number of lines to scroll by
787− -> Behavior t Text
788− -> m (Behavior t (Int, Int))
789− -- ^ (Current scroll position, total number of lines)
790−scrollableText scrollBy t = do
791− dw <- displayWidth
792− let imgs = wrap <$> current dw <*> t
793− kup <- key V.KUp
794− kdown <- key V.KDown
795− m <- mouseScroll
796− let requestedScroll :: Event t Int
797− requestedScroll = leftmost
798− [ 1 <$ kdown
799− , (-1) <$ kup
800− , ffor m $ \case
801− ScrollDirection_Up -> (-1)
802− ScrollDirection_Down -> 1
803− , scrollBy
804− ]
805− updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
806− lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
807− attach (length <$> imgs) requestedScroll
808− tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
809− return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
810− where
811− wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
812−
813−-- | Renders any behavior whose value can be converted to
814−-- 'String' as text
815−display
816− :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m)
817− => Behavior t a
818− -> m ()
819−display a = text $ T.pack . show <$> a
471+pane dr foc child = localRegion (const dr) $
472+ mapImages (imagesInRegion $ current dr) $
473+ localFocus (const foc) $
474+ inputInFocusedRegion >>= \e -> localInput (const e) child
820475
821476-- | A widget that draws nothing
822477blank :: Monad m => m ()