@@ -5,71 +5,17 @@ Description: Basic set of widgets and building blocks for reflex-vty application
5{-# Language UndecidableInstances #-}
5{-# Language UndecidableInstances #-}
7module Reflex.Vty.Widget where
7module Reflex.Vty.Widget where
10− -- , VtyWidgetOut(..)
14− -- , mainWidgetWithHandle
15− -- , HasDisplayRegion(..)
18− -- , HasVtyWidgetCtx(..)
21− -- , regionBlankImage
28− -- , ScrollDirection(..)
37− -- , RichTextConfig(..)
59import Control.Applicative (liftA2)
9import Control.Applicative (liftA2)
60import Control.Monad.Fix (MonadFix)
10import Control.Monad.Fix (MonadFix)
61import Control.Monad.IO.Class (MonadIO)
11import Control.Monad.IO.Class (MonadIO)
62import Control.Monad.Morph
12import Control.Monad.Morph
63import Control.Monad.NodeId
13import Control.Monad.NodeId
64−import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
14+import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
65import Control.Monad.Ref
15import Control.Monad.Ref
66import Control.Monad.Trans (MonadTrans, lift)
16import Control.Monad.Trans (MonadTrans, lift)
67−import Data.Default (Default(..))
68import Data.Set (Set)
17import Data.Set (Set)
69import qualified Data.Set as Set
18import 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
73import Graphics.Vty (Image)
19import Graphics.Vty (Image)
74import qualified Graphics.Vty as V
20import qualified Graphics.Vty as V
75import Reflex
21import Reflex
@@ -77,80 +23,9 @@ import Reflex.Class ()
77import Reflex.Host.Class (MonadReflexCreateTrigger)
23import Reflex.Host.Class (MonadReflexCreateTrigger)
78import Reflex.Vty.Host
24import Reflex.Vty.Host
80−-- | The context within which a 'VtyWidget' runs
26+-- * Running a vty application
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.
86−-- | The output of a 'VtyWidget'
87−data VtyWidgetOut t = VtyWidgetOut
88− { _vtyWidgetOut_shutdown :: Event t ()
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'
100−-- | A widget that can read its context and produce image output
101−newtype VtyWidget t m a = VtyWidget
103− ReaderT (VtyWidgetCtx t)
104− (ReaderT (Event t VtyEvent) m) a
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)
124−instance MonadTrans (VtyWidget t) where
125− lift f = VtyWidget $ lift $ lift f
127−instance MFunctor (VtyWidget t) where
128− hoist f = VtyWidget . hoist (hoist f) . unVtyWidget
130−instance MonadNodeId m => MonadNodeId (VtyWidget t m)
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
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
144−-- | Runs a 'VtyWidget' with a given context
146− :: (Reflex t, MonadNodeId m)
151−runVtyWidget e ctx w = runReaderT (runReaderT (unVtyWidget w) ctx) e
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
154mainWidgetWithHandle
29mainWidgetWithHandle
156 -> (forall t m.
31 -> (forall t m.
@@ -158,7 +33,9 @@ mainWidgetWithHandle
158 , HasImageWriter t m
33 , HasImageWriter t m
159 , MonadNodeId m
34 , MonadNodeId m
160 , HasDisplayRegion t m
35 , HasDisplayRegion t m
161− ) => VtyWidget t m (Event t ()))
38+ ) => m (Event t ()))
163mainWidgetWithHandle vty child =
40mainWidgetWithHandle vty child =
164 runVtyAppWithHandle vty $ \dr0 inp -> do
41 runVtyAppWithHandle vty $ \dr0 inp -> do
@@ -168,13 +45,10 @@ mainWidgetWithHandle vty child =
168 let inp' = fforMaybe inp $ \case
45 let inp' = fforMaybe inp $ \case
169 V.EvResize {} -> Nothing
46 V.EvResize {} -> Nothing
170 x -> Just x
47 x -> Just x
171− let ctx = VtyWidgetCtx
172− { _vtyWidgetCtx_focus = constDyn True
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) $
175 runImageWriter $
49 runImageWriter $
176 runNodeIdT $
50 runNodeIdT $
177− runVtyWidget inp' ctx $ do
51+ runInput inp' $ do
178 tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
52 tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
180 return $ VtyResult
54 return $ VtyResult
@@ -182,6 +56,11 @@ mainWidgetWithHandle vty child =
182 , _vtyResult_shutdown = shutdown
56 , _vtyResult_shutdown = shutdown
59+-- | The output of a vty widget
60+data VtyWidgetOut t = VtyWidgetOut
61+ { _vtyWidgetOut_shutdown :: Event t ()
185-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
64-- | Like 'mainWidgetWithHandle', but uses a default vty configuration
186mainWidget
65mainWidget
187 :: (forall t m.
66 :: (forall t m.
@@ -189,12 +68,167 @@ mainWidget
189 , HasImageWriter t m
68 , HasImageWriter t m
190 , MonadNodeId m
69 , MonadNodeId m
191 , HasDisplayRegion t m
70 , HasDisplayRegion t m
192− ) => VtyWidget t m (Event t ()))
73+ ) => m (Event t ()))
194mainWidget child = do
75mainWidget child = do
195 vty <- getDefaultVty
76 vty <- getDefaultVty
196 mainWidgetWithHandle vty child
77 mainWidgetWithHandle vty child
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)
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)
92+instance (Reflex t, Monad m) => HasInput t (Input t m) where
94+ localInput f (Input m) = Input $ local f m
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
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'
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)
128+instance MonadTrans (Input t) where
129+ lift f = Input $ lift f
131+instance MFunctor (Input t) where
132+ hoist f = Input . hoist f . unInput
134+instance MonadNodeId m => MonadNodeId (Input t m)
136+-- | Runs an 'Input' with a given context
142+runInput e w = runReaderT (unInput w) e
144+-- ** Filtering input
146+-- | Type synonym for a key and modifier combination
147+type KeyCombo = (V.Key, [V.Modifier])
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 . (,[])
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 (,[])
157+-- | Emit an event that fires whenever the provided key combination occurs
159+ :: (Reflex t, Monad m, HasInput t m)
161+ -> m (Event t KeyCombo)
162+keyCombo = keyCombos . Set.singleton
164+-- | Emit an event that fires whenever any of the provided key combinations occur
166+ :: (Reflex t, Monad m, HasInput t m)
168+ -> m (Event t KeyCombo)
171+ return $ fforMaybe i $ \case
172+ V.EvKey k m -> if Set.member (k, m) ks
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)
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.
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
197+ , y >= t + h ] = Nothing
199+ Just (con (x - l) (y - t))
201+-- | Filter mouse input outside the current display region and
202+-- all input if the region is not focused
204+ :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
205+ => m (Event t VtyEvent)
206+inputInFocusedRegion = do
208+ reg <- current <$> askRegion
209+ f <- current <$> focus
210+ pure $ gate f $ fmapMaybe id $ attachWith mouseInRegion reg inp
212+-- * Getting and setting the display region
214+-- | A chunk of the display area
216+ { _region_left :: Int
217+ , _region_top :: Int
218+ , _region_width :: Int
219+ , _region_height :: Int
221+ deriving (Show, Read, Eq, Ord)
223+-- | The width and height of a 'Region'
224+regionSize :: Region -> (Int, Int)
225+regionSize (Region _ _ w h) = (w, h)
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
198-- | A class for things that know their own display size dimensions
232-- | A class for things that know their own display size dimensions
199class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
233class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
200 -- | Retrieve the display region
234 -- | Retrieve the display region
@@ -206,9 +240,11 @@ class (Reflex t, Monad m) => HasDisplayRegion t m | m -> t where
206 default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a
240 default localRegion :: (f m' ~ m, Monad m', MFunctor f, HasDisplayRegion t m') => (Dynamic t Region -> Dynamic t Region) -> m a -> m a
207 localRegion f = hoist (localRegion f)
241 localRegion f = hoist (localRegion f)
243+-- | Retrieve the display width
209displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
244displayWidth :: HasDisplayRegion t m => m (Dynamic t Int)
210displayWidth = fmap _region_width <$> askRegion
245displayWidth = fmap _region_width <$> askRegion
247+-- | Retrieve the display height
212displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)
248displayHeight :: HasDisplayRegion t m => m (Dynamic t Int)
213displayHeight = fmap _region_height <$> askRegion
249displayHeight = fmap _region_height <$> askRegion
@@ -218,7 +254,9 @@ instance HasDisplayRegion t m => HasDisplayRegion t (DynamicWriterT t x m)
218instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)
254instance HasDisplayRegion t m => HasDisplayRegion t (EventWriterT t x m)
219instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)
255instance HasDisplayRegion t m => HasDisplayRegion t (NodeIdT m)
257+-- | A widget that has access to a particular region of the vty display
258+newtype DisplayRegion t m a = DisplayRegion
221−newtype DisplayRegion t m a = DisplayRegion { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
259+ { unDisplayRegion :: ReaderT (Dynamic t Region) m a }
223 ( Functor
261 ( Functor
224 , Applicative
262 , Applicative
@@ -240,6 +278,7 @@ deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
240deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
278deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
241deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
279deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
242instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
280instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
281+instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)
244instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
283instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
245 runWithReplace (DisplayRegion a) e = DisplayRegion $ runWithReplace a $ fmap unDisplayRegion e
284 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
247 traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
286 traverseDMapWithKeyWithAdjust f m e = DisplayRegion $ traverseDMapWithKeyWithAdjust (\k v -> unDisplayRegion $ f k v) m e
248 traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
287 traverseDMapWithKeyWithAdjustWithMove f m e = DisplayRegion $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unDisplayRegion $ f k v) m e
251instance MonadTrans (DisplayRegion t) where
289instance MonadTrans (DisplayRegion t) where
252 lift = DisplayRegion . lift
290 lift = DisplayRegion . lift
@@ -256,6 +294,7 @@ instance MFunctor (DisplayRegion t) where
257instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
295instance MonadNodeId m => MonadNodeId (DisplayRegion t m)
297+-- | Run a 'DisplayRegion' action with a given 'Region'
259runDisplayRegion
298runDisplayRegion
260 :: (Reflex t, Monad m)
299 :: (Reflex t, Monad m)
261 => Dynamic t Region
300 => Dynamic t Region
@@ -263,33 +302,71 @@ runDisplayRegion
264runDisplayRegion r = flip runReaderT r . unDisplayRegion
303runDisplayRegion r = flip runReaderT r . unDisplayRegion
266−-- | A class for things that can receive vty events as input
305+-- * Getting focus state
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)
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
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)
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
285-- | A class for things that can dynamically gain and lose focus
307-- | 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
287 focus :: m (Dynamic t Bool)
309 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)
289 focus = lift focus
311 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)
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)
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 }
336+instance (Monad m, Reflex t) => HasFocusReader t (FocusReader t m) where
337+ focus = FocusReader ask
338+ localFocus f = FocusReader . local f . unFocusReader
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)
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
353+instance MonadTrans (FocusReader t) where
354+ lift = FocusReader . lift
356+instance MFunctor (FocusReader t) where
357+ hoist f = FocusReader . hoist f . unFocusReader
359+instance MonadNodeId m => MonadNodeId (FocusReader t m)
361+-- | Run a 'FocusReader' action with the given focus value
291−instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
363+ :: (Reflex t, Monad m)
292− focus = VtyWidget $ asks _vtyWidgetCtx_focus
364+ => Dynamic t Bool
365+ -> FocusReader t m a
367+runFocusReader b = flip runReaderT b . unFocusReader
294-- | A class for widgets that can produce images to draw to the display
371-- | A class for widgets that can produce images to draw to the display
295class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
372class (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
302 default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
379 default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
303 mapImages f = hoist (mapImages f)
380 mapImages f = hoist (mapImages f)
382+-- | A widget that can produce images to draw onto the display
383+newtype ImageWriter t m a = ImageWriter
305−newtype ImageWriter t m a = ImageWriter { unImageWriter :: BehaviorWriterT t [Image] m a }
384+ { unImageWriter :: BehaviorWriterT t [Image] m a }
307 ( Functor
386 ( Functor
308 , Applicative
387 , Applicative
@@ -345,30 +424,16 @@ instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
347instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
426instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
427+instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
429+-- | Run a widget that can produce images
349runImageWriter
430runImageWriter
350 :: (Reflex t, Monad m)
431 :: (Reflex t, Monad m)
351 => ImageWriter t m a
432 => ImageWriter t m a
352 -> m (a, Behavior t [Image])
433 -> m (a, Behavior t [Image])
353runImageWriter = runBehaviorWriterT . unImageWriter
434runImageWriter = runBehaviorWriterT . unImageWriter
355−-- | A chunk of the display area
436+-- ** Manipulating images
357− { _region_left :: Int
358− , _region_top :: Int
359− , _region_width :: Int
360− , _region_height :: Int
362− deriving (Show, Read, Eq, Ord)
364−-- | The width and height of a 'Region'
365−regionSize :: Region -> (Int, Int)
366−regionSize (Region _ _ w h) = (w, h)
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
373-- | Translates and crops an 'Image' so that it is contained by
438-- | Translates and crops an 'Image' so that it is contained by
374-- the given 'Region'.
439-- the given 'Region'.
@@ -380,7 +445,17 @@ withinImage (Region left top width height)
380 | width < 0 || height < 0 = withinImage (Region left top 0 0)
445 | width < 0 || height < 0 = withinImage (Region left top 0 0)
381 | otherwise = V.translate left top . V.crop width height
446 | otherwise = V.translate left top . V.crop width height
448+-- | Crop a behavior of images to a behavior of regions. See 'withinImage'.
451+ => Behavior t Region
452+ -> Behavior t [Image]
453+ -> Behavior t [Image]
454+imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
456+-- * Running sub-widgets
383−-- | Low-level widget combinator that runs a child 'VtyWidget' within
458+-- | Low-level widget combinator that runs a child 'Input' within
384-- a given region and context. This widget filters and modifies the input
459-- a given region and context. This widget filters and modifies the input
385-- that the child widget receives such that:
460-- that the child widget receives such that:
386-- * unfocused widgets receive no key events
461-- * unfocused widgets receive no key events
@@ -388,435 +463,15 @@ withinImage (Region left top width height)
388-- * mouse inputs inside the region have their coordinates translated such
463-- * mouse inputs inside the region have their coordinates translated such
389-- that (0,0) is the top-left corner of the region
464-- that (0,0) is the top-left corner of the region
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)
392 => Dynamic t Region
467 => Dynamic t Region
393 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
468 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
396−pane dr foc child = do
471+pane dr foc child = localRegion (const dr) $
397− let reg = current dr
472+ mapImages (imagesInRegion $ current dr) $
398− let subContext ctx = VtyWidgetCtx
473+ localFocus (const foc) $
399− { _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
474+ inputInFocusedRegion >>= \e -> localInput (const e) child
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
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
418− , y >= t + h ] = Nothing
420− Just (con (x - l) (y - t))
422−-- | Information about a drag operation
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)
430− deriving (Eq, Ord, Show)
432−-- | Converts raw vty mouse drag events into an event stream of 'Drag's
434− :: (Reflex t, MonadFix m, MonadHold t m, HasVtyInput t m)
439− let f :: Maybe Drag -> V.Event -> Maybe Drag
441− V.EvMouseDown x y btn' mods
442− | btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
443− | otherwise -> 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')
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.
457− | otherwise -> Just $ Drag from (x,y) btn mods True
459− rec let newDrag = attachWithMaybe f (current dragD) inp
460− dragD <- holdDyn Nothing $ Just <$> newDrag
461− return (fmapMaybe id $ updated dragD)
463−-- | Mouse down events for a particular mouse button
465− :: (Reflex t, Monad m, HasVtyInput t m)
467− -> m (Event t MouseDown)
470− return $ fforMaybe i $ \case
471− V.EvMouseDown x y btn' mods -> if btn == btn'
472− then Just $ MouseDown btn' (x, y) mods
476−-- | Mouse up events for a particular mouse button
478− :: (Reflex t, Monad m, HasVtyInput t m)
479− => m (Event t MouseUp)
482− return $ fforMaybe i $ \case
483− V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
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]
492− deriving (Eq, Ord, Show)
494−-- | Information about a mouse up event
495−data MouseUp = MouseUp
496− { _mouseUp_button :: Maybe V.Button
497− , _mouseUp_coordinates :: (Int, Int)
499− deriving (Eq, Ord, Show)
501−-- | Mouse scroll direction
502−data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
503− deriving (Eq, Ord, Show)
505−-- | Produce an event that fires when the mouse wheel is scrolled
507− :: (Reflex t, Monad m, HasVtyInput t m)
508− => m (Event t ScrollDirection)
510− up <- mouseDown V.BScrollUp
511− down <- mouseDown V.BScrollDown
513− [ ScrollDirection_Up <$ up
514− , ScrollDirection_Down <$ down
517−-- | Type synonym for a key and modifier combination
518−type KeyCombo = (V.Key, [V.Modifier])
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 . (,[])
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 (,[])
528−-- | Emit an event that fires whenever the provided key combination occurs
530− :: (Reflex t, Monad m, HasVtyInput t m)
532− -> m (Event t KeyCombo)
533−keyCombo = keyCombos . Set.singleton
535−-- | Emit an event that fires whenever any of the provided key combinations occur
537− :: (Reflex t, Monad m, HasVtyInput t m)
539− -> m (Event t KeyCombo)
542− return $ fforMaybe i $ \case
543− V.EvKey k m -> if Set.member (k, m) ks
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.
556− -- ^ Widget for first pane
558− -- ^ Widget for second pane
560−splitV sizeFunD focD wA wB = do
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
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.
577− -- ^ Widget for first pane
579− -- ^ Widget for second pane
581−splitH sizeFunD focD wA wB = do
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)
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)
596−splitVDrag wS wA wB = do
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
618− (mA, rA) <- pane regA focA $ withMouseDown wA
619− pane regS (pure False) wS
620− (mB, rB) <- pane regB (not <$> focA) $ withMouseDown wB
623− withMouseDown x = do
624− m <- mouseDown V.BLeft
628−-- | Fill the background with a particular character.
629−fill :: (HasDisplayRegion t m, HasImageWriter t m) => Behavior t Char -> m ()
634− (\w h c -> [V.charFill V.defAttr c w h])
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)
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
657−instance Default BoxStyle where
658− def = singleBoxStyle
660−-- | A box style that uses hyphens and pipe characters. Doesn't handle
661−-- corners very well.
662−hyphenBoxStyle :: BoxStyle
663−hyphenBoxStyle = BoxStyle '-' '-' '-' '|' '-' '-' '-' '|'
665−-- | A single line box style
666−singleBoxStyle :: BoxStyle
667−singleBoxStyle = BoxStyle '┌' '─' '┐' '│' '┘' '─' '└' '│'
669−-- | A thick single line box style
670−thickBoxStyle :: BoxStyle
671−thickBoxStyle = BoxStyle '┏' '━' '┓' '┃' '┛' '━' '┗' '┃'
673−-- | A double line box style
674−doubleBoxStyle :: BoxStyle
675−doubleBoxStyle = BoxStyle '╔' '═' '╗' '║' '╝' '═' '╚' '║'
677−-- | A single line box style with rounded corners
678−roundedBoxStyle :: BoxStyle
679−roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
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
687−boxTitle boxStyle title child = do
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
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
701− [ withinImage (Region (left + 1) top (width - 2) 1) $
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)
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)
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
725− else left <> t <> right
729− mkHalf n = T.replicate (n `div` 2) (T.singleton c)
730− left = mkHalf $ delta + 1
731− right = mkHalf delta
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
738−box boxStyle = boxTitle boxStyle mempty
740−-- | A box whose style is static
742− :: (Monad m, Reflex t, MonadNodeId m, HasDisplayRegion t m, HasImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
746−boxStatic = box . pure
748−-- | Configuration options for displaying "rich" text
749−data RichTextConfig t = RichTextConfig
750− { _richTextConfig_attributes :: Behavior t V.Attr
753−instance Reflex t => Default (RichTextConfig t) where
754− def = RichTextConfig $ pure V.defAttr
756−-- | A widget that displays text with custom time-varying attributes
758− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
764− let img = (\w a s -> [wrapText w a s])
766− <*> _richTextConfig_attributes cfg
770− wrapText maxWidth attrs = V.vertCat
771− . concatMap (fmap (V.string attrs . T.unpack) . TZ.wrapWithOffset maxWidth 0)
774−-- | Renders text, wrapped to the container width
776− :: (Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m)
781−-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
784− :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasVtyInput t m, HasImageWriter t m)
786− -- ^ Number of lines to scroll by
788− -> m (Behavior t (Int, Int))
789− -- ^ (Current scroll position, total number of lines)
790−scrollableText scrollBy t = do
792− let imgs = wrap <$> current dw <*> t
794− kdown <- key V.KDown
796− let requestedScroll :: Event t Int
797− requestedScroll = leftmost
801− ScrollDirection_Up -> (-1)
802− ScrollDirection_Down -> 1
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)
811− wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
813−-- | Renders any behavior whose value can be converted to
816− :: (Reflex t, Monad m, Show a, HasDisplayRegion t m, HasImageWriter t m)
819−display a = text $ T.pack . show <$> a
821-- | A widget that draws nothing
476-- | A widget that draws nothing
822blank :: Monad m => m ()
477blank :: Monad m => m ()