git.iko.soy/reflex-vty
on develop help sign in
moar things
815c86aCale Gibbard
src-bin/example.hs+24−15
compare with develop
unifiedsplit
@@ -7,10 +7,10 @@
7{-# OPTIONS_GHC -threaded #-}
7{-# OPTIONS_GHC -threaded #-}
8
8
9import Control.Monad
9import Control.Monad
10+import Control.Monad.Fix
10import Control.Monad.IO.Class
11import Control.Monad.IO.Class
11import Control.Monad.Trans.Reader
12import Control.Monad.Trans.Reader
12import Data.Time
13import Data.Time
13−import Graphics.Vty as V hiding (Event)
14import qualified Graphics.Vty as V
14import qualified Graphics.Vty as V
15import Reflex
15import Reflex
16import Reflex.Vty
16import Reflex.Vty
@@ -52,21 +52,30 @@ main =
52 V.EvKey V.KEsc _ -> Just ()
52 V.EvKey V.KEsc _ -> Just ()
53 _ -> Nothing
53 _ -> Nothing
54
54
55− size <- displaySize
55+ debugInput
56− let region = fmap (\(w,h) -> Region 0 0 w h) size
56+ testBoxes
57− region1 = fmap (\(w,h) -> Region (w `div` 5) (h `div` 5) (w `div` 2) (h `div` 2)) size
57+ return ()
58− region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
59− debugRegion = fmap (\(w, _) -> Region 0 0 w 3) size
60
58
61− forM_ [region1, region2] $ \r -> pane r (constDyn False) $ testStringBox
59+testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
60+testBoxes = do
61+ size <- displaySize
62+ let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size
63+ region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
64+ pane region1 (constDyn False) . box $ debugInput
62− pane debugRegion (constDyn True) $ do
65+ pane region2 (constDyn True) . box $
66+ splitV (pure $ fractionSz 0.5) (pure (True, True)) (box debugInput) (box dragTest)
67+ return ()
68+
69+debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
70+debugInput = do
63− lastEvent <- hold "" . fmap show =<< input
71+ lastEvent <- hold "No event yet" . fmap show =<< input
64− tellImages . ffor (liftM2 (,) (current debugRegion) lastEvent) $ \(r, le) ->
72+ string lastEvent
65− box r (\(w,_) -> wrapString w mempty le)
66
73
74+dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
75+dragTest = do
76+ lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
77+ string lastEvent
67
78
68testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
79testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
69−testStringBox = do
80+testStringBox = box .
70− size <- displaySize
71− tellImages . ffor (current size) $ \(w,h) ->
72− box (Region 0 0 w h) (\_ -> wrapString w mempty . take 500 $ cycle ('\n' : ['a'..'z']))
81+ string . pure . take 500 $ cycle ('\n' : ['a'..'z'])
src/Reflex/Vty.hs+151−48
@@ -8,6 +8,7 @@
8{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE FunctionalDependencies #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE ConstraintKinds #-}
10{-# LANGUAGE ConstraintKinds #-}
11+{-# LANGUAGE RecursiveDo #-}
11
12
12{-# OPTIONS_GHC -Wall #-}
13{-# OPTIONS_GHC -Wall #-}
13
14
@@ -18,16 +19,20 @@ module Reflex.Vty
18 , runVtyApp
19 , runVtyApp
19 , runVtyAppWith
20 , runVtyAppWith
20 , HasDisplaySize(..)
21 , HasDisplaySize(..)
22+ , displayWidth
23+ , displayHeight
21 , HasFocus(..)
24 , HasFocus(..)
22 , HasVtyInput(..)
25 , HasVtyInput(..)
23 , Region(..)
26 , Region(..)
24− , regionToDisplayRegion
27+ , regionSize
25− , region
28+ , regionBlankImage
26− , box
29+ , boxImages
27 , runVtyWidget
30 , runVtyWidget
28 , VtyWidgetCtx(..)
31 , VtyWidgetCtx(..)
29 , VtyWidget(..)
32 , VtyWidget(..)
30 , VtyWidgetOut(..)
33 , VtyWidgetOut(..)
34+ , Drag (..)
35+ , drag
31 , pane
36 , pane
32 , modifyImages
37 , modifyImages
33 , mainVtyWidget
38 , mainVtyWidget
@@ -35,6 +40,10 @@ module Reflex.Vty
35 , tellImages
40 , tellImages
36 , tellShutdown
41 , tellShutdown
37 , wrapString
42 , wrapString
43+ , splitV
44+ , fractionSz
45+ , box
46+ , string
38 ) where
47 ) where
39
48
40import Control.Applicative
49import Control.Applicative
@@ -258,41 +267,40 @@ data Region = Region
258 }
267 }
259 deriving (Show, Read, Eq, Ord)
268 deriving (Show, Read, Eq, Ord)
260
269
261−regionToDisplayRegion :: Region -> DisplayRegion
270+regionSize :: Region -> (Int, Int)
262−regionToDisplayRegion (Region _ _ w h) = (w, h)
271+regionSize (Region _ _ w h) = (w, h)
263
272
264−region :: Region -> (DisplayRegion -> Image) -> [Image]
273+regionBlankImage :: Region -> Image
265−region r@(Region _ _ width height) i =
274+regionBlankImage r@(Region _ _ width height) =
266− [ within r $ V.resize width height $ i (width, height)
267− , within r $ wrapString width V.defAttr $ replicate (width * height) ' '
275+ withinImage r $ wrapString width V.defAttr $ replicate (width * height) ' '
268− ]
269
276
270−within :: Region -> Image -> Image
277+withinImage :: Region -> Image -> Image
271−within (Region left top width height) =
278+withinImage (Region left top width height)
279+ | width < 0 || height < 0 = withinImage (Region left top 0 0)
272− V.translate left top . V.crop width height
280+ | otherwise = V.translate left top . V.crop width height
273
281
274wrapString :: Int -> Attr -> String -> Image
282wrapString :: Int -> Attr -> String -> Image
275wrapString maxWidth attrs = V.vertCat . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
283wrapString maxWidth attrs = V.vertCat . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
276
284
277−box :: Region -> (DisplayRegion -> Image) -> [Image]
285+boxImages :: Region -> [Image]
278−box r@(Region left top width height) i =
286+boxImages r@(Region left top width height) =
279 let hBorder = V.string mempty $ replicate width '-'
287 let hBorder = V.string mempty $ replicate width '-'
280 vBorder = wrapString 1 mempty $ replicate (height - 2) '|'
288 vBorder = wrapString 1 mempty $ replicate (height - 2) '|'
281− internal = Region
282− { _region_left = left + 1
283− , _region_top = top + 1
284− , _region_width = width - 2
285− , _region_height = height - 2
286− }
287− in [ within (r { _region_height = 1 }) hBorder
289+ in [ withinImage (r { _region_height = 1 }) hBorder
288− , within (Region left (top + 1) 1 (height - 2)) vBorder
290+ , withinImage (Region left (top + 1) 1 (height - 2)) vBorder
289− , within (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
291+ , withinImage (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
290− , within (r { _region_top = top + height - 1 }) hBorder
292+ , withinImage (r { _region_top = top + height - 1 }) hBorder
291− ] ++ region internal i
293+ ]
292−
294+
293−class HasDisplaySize t m | m -> t where
295+class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
294 displaySize :: m (Dynamic t (Int, Int))
296 displaySize :: m (Dynamic t (Int, Int))
295
297
298+displayWidth :: HasDisplaySize t m => m (Dynamic t Int)
299+displayWidth = fmap fst <$> displaySize
300+
301+displayHeight :: HasDisplaySize t m => m (Dynamic t Int)
302+displayHeight = fmap snd <$> displaySize
303+
296class HasVtyInput t m | m -> t where
304class HasVtyInput t m | m -> t where
297 input :: m (Event t VtyEvent)
305 input :: m (Event t VtyEvent)
298
306
@@ -324,9 +332,9 @@ instance (Reflex t) => Monoid (VtyWidgetOut t) where
324 mappend wo wo' = wo <> wo'
332 mappend wo wo' = wo <> wo'
325
333
326newtype VtyWidget t m a = VtyWidget { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a }
334newtype VtyWidget t m a = VtyWidget { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a }
327− deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t)
335+ deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix)
328
336
329−runVtyWidget :: (MonadFix m, Reflex t)
337+runVtyWidget :: (Reflex t)
330 => VtyWidgetCtx t
338 => VtyWidgetCtx t
331 -> VtyWidget t m a
339 -> VtyWidget t m a
332 -> m (a, VtyWidgetOut t)
340 -> m (a, VtyWidgetOut t)
@@ -345,7 +353,7 @@ mainVtyWidget child =
345 }
353 }
346 ((), wo) <- runVtyWidget ctx child
354 ((), wo) <- runVtyWidget ctx child
347 return $ VtyResult
355 return $ VtyResult
348− { _vtyResult_picture = fmap V.picForLayers (_vtyWidgetOut_images wo)
356+ { _vtyResult_picture = fmap (V.picForLayers . reverse) (_vtyWidgetOut_images wo)
349 , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo
357 , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo
350 }
358 }
351
359
@@ -370,38 +378,133 @@ tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })
370tellShutdown :: (Reflex t, Monad m) => Event t () -> VtyWidget t m ()
378tellShutdown :: (Reflex t, Monad m) => Event t () -> VtyWidget t m ()
371tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })
379tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })
372
380
373−pane :: (MonadFix m, Reflex t)
381+data Drag = Drag
382+ { _drag_from :: (Int, Int) -- ^ Where the drag began
383+ , _drag_to :: (Int, Int) -- ^ Where the mouse currently is
384+ , _drag_button :: V.Button -- ^ Which mouse button is dragging
385+ , _drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
386+ , _drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
387+ }
388+ deriving (Eq, Ord, Show)
389+
390+drag :: (Reflex t, MonadFix m, MonadHold t m) => V.Button -> VtyWidget t m (Event t Drag)
391+drag btn = do
392+ inp <- input
393+ let f :: Drag -> V.Event -> Maybe Drag
394+ f (Drag from _ _ mods end) = \case
395+ V.EvMouseDown x y btn' mods'
396+ | end -> Just $ Drag (x,y) (x,y) btn' mods' False
397+ | btn == btn' -> Just $ Drag from (x,y) btn mods' False
398+ | otherwise -> Nothing -- Ignore other buttons.
399+ V.EvMouseUp x y (Just btn')
400+ | end -> Nothing
401+ | btn == btn' -> Just $ Drag from (x,y) btn mods True
402+ | otherwise -> Nothing
403+ V.EvMouseUp x y Nothing -- Terminal doesn't specify mouse up button,
404+ -- assume it's the right one.
405+ | end -> Nothing
406+ | otherwise -> Just $ Drag from (x,y) btn mods True
407+ _ -> Nothing
408+ rec let newDrag = attachWithMaybe f (current dragD) inp
409+ dragD <- holdDyn (Drag (0,0) (0,0) V.BLeft [] True) -- gross, but ok.
410+ newDrag
411+ return (updated dragD)
412+
413+pane :: (Reflex t, Monad m)
374 => Dynamic t Region -- ^ Region into which we should draw the widget (in coordinates relative to our own)
414 => Dynamic t Region -- ^ Region into which we should draw the widget (in coordinates relative to our own)
375− -> Dynamic t Bool -- ^ Whether the widget is focused
415+ -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
376 -> VtyWidget t m a
416 -> VtyWidget t m a
377 -> VtyWidget t m a
417 -> VtyWidget t m a
378−pane reg foc w = VtyWidget $ do
418+pane reg foc child = VtyWidget $ do
379 ctx <- lift ask
419 ctx <- lift ask
380 let ctx' = VtyWidgetCtx
420 let ctx' = VtyWidgetCtx
421+ { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.
422+ [ ffor (updated reg) $ \(Region _ _ w h) -> V.EvResize w h
381− { _vtyWidgetCtx_input = fmapMaybe id $
423+ , fmapMaybe id $
382− attachWith (\(r,f) e -> filterInput r f e)
424+ attachWith (\(r,f) e -> filterInput r f e)
383− (liftA2 (,) (current reg) (current foc))
425+ (liftA2 (,) (current reg) (current foc))
384− (_vtyWidgetCtx_input ctx)
426+ (_vtyWidgetCtx_input ctx)
427+ ]
385− , _vtyWidgetCtx_focus = foc
428+ , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
386− , _vtyWidgetCtx_size = fmap regionToDisplayRegion reg }
429+ , _vtyWidgetCtx_size = fmap regionSize reg }
387− (result, wo) <- lift . lift $ runVtyWidget ctx' w
430+ (result, wo) <- lift . lift $ runVtyWidget ctx' child
388 let images = _vtyWidgetOut_images wo
431 let images = _vtyWidgetOut_images wo
389− images' = liftA2 (\r is -> map (within r) is) (current reg) images
432+ images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images
390 wo' = wo { _vtyWidgetOut_images = images' }
433 wo' = wo { _vtyWidgetOut_images = images' }
391 tell wo'
434 tell wo'
392 return result
435 return result
393
436
394filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
437filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
395−filterInput r focused e = case e of
438+filterInput (Region l t w h) focused e = case e of
396 V.EvKey _ _ | not focused -> Nothing
439 V.EvKey _ _ | not focused -> Nothing
397 V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
440 V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
398 V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
441 V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
399 _ -> Just e
442 _ -> Just e
400 where
443 where
401 mouse con x y
444 mouse con x y
402− | or [ x < 0
445+ | or [ x < l
403− , y < 0
446+ , y < t
404− , x >= _region_width r
447+ , x >= l + w
405− , y >= _region_height r ] = Nothing
448+ , y >= t + h ] = Nothing
406 | otherwise =
449 | otherwise =
407− Just (con (x + _region_left r) (y + _region_top r))
450+ Just (con (x - l) (y - t))
451+
452+-- | A plain split of the available space into vertically stacked panes.
453+-- No visual separator is built in here.
454+splitV :: (Reflex t, Monad m)
455+ => Dynamic t (Int -> Int)
456+ -- ^ Function used to determine size of first pane based on available size
457+ -> Dynamic t (Bool, Bool)
458+ -- ^ How to focus the two sub-panes, given that we are focused.
459+ -> VtyWidget t m a
460+ -- ^ Widget for first pane
461+ -> VtyWidget t m b
462+ -- ^ Widget for second pane
463+ -> VtyWidget t m (a,b)
464+splitV sizeFunD focD wA wB = do
465+ sz <- displaySize
466+ let regA = (\f (w,h) -> Region 0 0 w (f h)) <$> sizeFunD <*> sz
467+ regB = (\(w,h) (Region _ _ _ hA) -> Region 0 hA w (h - hA)) <$> sz <*> regA
468+ ra <- pane regA (fst <$> focD) wA
469+ rb <- pane regB (snd <$> focD) wB
470+ return (ra,rb)
471+
472+
473+
474+-- | A split of the available space into two parts with a draggable separator.
475+-- Starts with half the space allocated to each, and the first pane has focus.
476+-- Clicking in a pane switches focus.
477+{-
478+splitVDrag :: (Reflex t, Monad m)
479+ => VtyWidget t m a
480+ -> VtyWidget t m b
481+ -> VtyWidget t m (a,b)
482+splitVDrag wA wB = do
483+ sz <- displaySize
484+ let splitterPos = ffor sz $ \(_,h) -> h `div` 2
485+ regA = (\(w,_) sp -> Region 0 0 w sp) <$> sz <*> splitterPos
486+ regS = (\(w,h) sp -> Region 0 sp w 1) <$> sz <*> splitterPos
487+ regB = (\(w,h) sp -> Region 0 (sp + 1) w (h - sp - 1)) <$> sz <*> splitterPos
488+ foc <- holdDyn False []
489+ (rA, inpA) <- pane wA
490+-}
491+
492+fractionSz :: Double -> Int -> Int
493+fractionSz x h = round (fromIntegral h * x)
494+
495+box :: (Monad m, Reflex t)
496+ => VtyWidget t m a
497+ -> VtyWidget t m a
498+box child = do
499+ sz <- displaySize
500+ let boxReg = ffor (current sz) $ \(w,h) -> Region 0 0 w h
501+ innerReg = ffor sz $ \(w,h) -> Region 1 1 (w - 2) (h - 2)
502+ tellImages (fmap boxImages boxReg)
503+ tellImages (fmap (\r -> [regionBlankImage r]) (current innerReg))
504+ pane innerReg (pure True) child
505+
506+string :: (Reflex t, Monad m) => Behavior t String -> VtyWidget t m ()
507+string msg = do
508+ dw <- displayWidth
509+ let img = (\w s -> [wrapString w mempty s]) <$> current dw <*> msg
510+ tellImages img