git.iko.soy/reflex-vty
on develop help sign in
beginnings of widgets
36d73e1Cale Gibbard
reflex-vty.cabal+1
compare with develop
unifiedsplit
@@ -30,6 +30,7 @@ library
30executable example
30executable example
31 hs-source-dirs: src-bin
31 hs-source-dirs: src-bin
32 main-is: example.hs
32 main-is: example.hs
33+ ghc-options: -threaded
33 build-depends:
34 build-depends:
34 base,
35 base,
35 reflex,
36 reflex,
src-bin/example.hs+33−44
@@ -4,58 +4,22 @@
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7+{-# OPTIONS_GHC -threaded #-}
7
8
9+import Control.Monad
8import Control.Monad.IO.Class
10import Control.Monad.IO.Class
9import Control.Monad.Trans.Reader
11import Control.Monad.Trans.Reader
10import Data.Time
12import Data.Time
11−import Graphics.Vty as V
13+import Graphics.Vty as V hiding (Event)
14+import qualified Graphics.Vty as V
12import Reflex
15import Reflex
13import Reflex.Vty
16import Reflex.Vty
14
17
15−data Region = Region
18+{-
16− { _region_left :: Int
17− , _region_top :: Int
18− , _region_width :: Int
19− , _region_height :: Int
20− }
21− deriving (Show, Read, Eq, Ord)
22−
23−regionToDisplayRegion :: Region -> DisplayRegion
24−regionToDisplayRegion (Region _ _ w h) = (w, h)
25−
26−region :: Region -> (DisplayRegion -> Image) -> [Image]
27−region r@(Region left top width height) i =
28− [ within r $ resize width height $ i (width, height)
29− , within r $ wrapString width defAttr $ replicate (width * height) ' '
30− ]
31−
32−within :: Region -> Image -> Image
33−within (Region left top width height) =
34− translate left top . V.crop width height
35−
36−wrapString :: Int -> Attr -> String -> Image
37−wrapString maxWidth attrs = vertCat . concatMap (fmap (string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
38−
39−box :: Region -> (DisplayRegion -> Image) -> [Image]
40−box r@(Region left top width height) i =
41− let hBorder = string mempty $ replicate width '-'
42− vBorder = wrapString 1 mempty $ replicate (height - 2) '|'
43− internal = Region
44− { _region_left = left + 1
45− , _region_top = top + 1
46− , _region_width = width - 2
47− , _region_height = height - 2
48− }
49− in [ within (r { _region_height = 1 }) hBorder
50− , within (Region left (top + 1) 1 (height - 2)) vBorder
51− , within (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
52− , within (r { _region_top = top + height - 1 }) hBorder
53− ] ++ region internal i
54−
55guest :: forall t m. VtyApp t m
19guest :: forall t m. VtyApp t m
56guest e = do
20guest e = do
57− dr0@(w, h) <- displayRegion
21+ dr0@(w, h) <- displaySize
58− dr <- holdDyn dr0 $ fforMaybe e $ \case
22+ dr <- holdDyn dr0 $ fforMaybe (e :: Event t VtyEvent) $ \case
59 V.EvResize w h -> Just (w, h)
23 V.EvResize w h -> Just (w, h)
60 _ -> Nothing
24 _ -> Nothing
61 let region = fmap (\(w,h) -> Region 0 0 w h) dr
25 let region = fmap (\(w,h) -> Region 0 0 w h) dr
@@ -78,6 +42,31 @@ guest e = do
78 { _vtyResult_picture = output
42 { _vtyResult_picture = output
79 , _vtyResult_shutdown = shutdown
43 , _vtyResult_shutdown = shutdown
80 }
44 }
45+-}
81
46
82main :: IO ()
47main :: IO ()
83−main = runVtyApp guest
48+main =
49+ mainVtyWidget $ do
50+ inp <- input
51+ tellShutdown . fforMaybe inp $ \case
52+ V.EvKey V.KEsc _ -> Just ()
53+ _ -> Nothing
54+
55+ size <- displaySize
56+ let region = fmap (\(w,h) -> Region 0 0 w h) size
57+ region1 = fmap (\(w,h) -> Region (w `div` 5) (h `div` 5) (w `div` 2) (h `div` 2)) size
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+
61+ forM_ [region1, region2] $ \r -> pane r (constDyn False) $ testStringBox
62+ pane debugRegion (constDyn True) $ do
63+ lastEvent <- hold "" . fmap show =<< input
64+ tellImages . ffor (liftM2 (,) (current debugRegion) lastEvent) $ \(r, le) ->
65+ box r (\(w,_) -> wrapString w mempty le)
66+
67+
68+testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
69+testStringBox = do
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']))
src/Reflex/Vty.hs+199−14
@@ -5,15 +5,39 @@
5{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE ConstraintKinds #-}
11+
12+{-# OPTIONS_GHC -Wall #-}
8
13
9module Reflex.Vty
14module Reflex.Vty
10 ( VtyApp
15 ( VtyApp
11 , VtyResult(..)
16 , VtyResult(..)
17+ , VtyEvent
12 , runVtyApp
18 , runVtyApp
13 , runVtyAppWith
19 , runVtyAppWith
14− , HasDisplayRegion(..)
20+ , HasDisplaySize(..)
21+ , HasFocus(..)
22+ , HasVtyInput(..)
23+ , Region(..)
24+ , regionToDisplayRegion
25+ , region
26+ , box
27+ , runVtyWidget
28+ , VtyWidgetCtx(..)
29+ , VtyWidget(..)
30+ , VtyWidgetOut(..)
31+ , pane
32+ , modifyImages
33+ , mainVtyWidget
34+ , filterInput
35+ , tellImages
36+ , tellShutdown
37+ , wrapString
15 ) where
38 ) where
16
39
40+import Control.Applicative
17import Control.Concurrent (forkIO, killThread)
41import Control.Concurrent (forkIO, killThread)
18import Control.Concurrent.Chan (newChan, readChan, writeChan)
42import Control.Concurrent.Chan (newChan, readChan, writeChan)
19import Control.Monad (forM, forM_, forever)
43import Control.Monad (forM, forM_, forever)
@@ -23,6 +47,8 @@ import Control.Monad.Identity (Identity(..))
23import Control.Monad.Primitive (PrimMonad)
47import Control.Monad.Primitive (PrimMonad)
24import Control.Monad.Ref (MonadRef, Ref, readRef)
48import Control.Monad.Ref (MonadRef, Ref, readRef)
25import Control.Monad.Trans.Reader
49import Control.Monad.Trans.Reader
50+import Control.Monad.Trans.Writer
51+import Control.Monad.Trans
26import Data.Dependent.Sum (DSum ((:=>)))
52import Data.Dependent.Sum (DSum ((:=>)))
27import Data.IORef (IORef)
53import Data.IORef (IORef)
28import Data.IORef (readIORef)
54import Data.IORef (readIORef)
@@ -33,6 +59,9 @@ import Reflex.Host.Class
33import Reflex.NotReady.Class
59import Reflex.NotReady.Class
34import Reflex.Spider.Orphans ()
60import Reflex.Spider.Orphans ()
35import qualified Graphics.Vty as V
61import qualified Graphics.Vty as V
62+import Graphics.Vty (DisplayRegion, Image, Attr)
63+
64+type VtyEvent = V.Event
36
65
37-- | The output of a 'VtyApp'.
66-- | The output of a 'VtyApp'.
38data VtyResult t = VtyResult
67data VtyResult t = VtyResult
@@ -43,14 +72,7 @@ data VtyResult t = VtyResult
43 -- ^ An event that requests application termination.
72 -- ^ An event that requests application termination.
44 }
73 }
45
74
46−class HasDisplayRegion m where
47− displayRegion :: m V.DisplayRegion
48−
49−instance Monad m => HasDisplayRegion (ReaderT V.DisplayRegion m) where
50− displayRegion = ask
51−
52−-- | A functional reactive vty application.
53−type VtyApp t m =
75+type MonadVtyApp t m =
54 ( Reflex t
76 ( Reflex t
55 , MonadHold t m
77 , MonadHold t m
56 , MonadFix m
78 , MonadFix m
@@ -66,10 +88,13 @@ type VtyApp t m =
66 , PerformEvent t m
88 , PerformEvent t m
67 , MonadIO m
89 , MonadIO m
68 , MonadIO (Performable m)
90 , MonadIO (Performable m)
69−
70− , HasDisplayRegion m
71 )
91 )
92+
93+-- | A functional reactive vty application.
94+type VtyApp t m = MonadVtyApp t m
95+ => DisplayRegion
96+ -- ^ The initial display size (updates to this come as events)
72− => Event t (V.Event)
97+ -> Event t (V.Event)
73 -- ^ Vty input events.
98 -- ^ Vty input events.
74 -> m (VtyResult t)
99 -> m (VtyResult t)
75 -- ^ The output of the 'VtyApp'. The application runs in a context that,
100 -- ^ The output of the 'VtyApp'. The application runs in a context that,
@@ -127,8 +152,9 @@ runVtyAppWith vty vtyGuest =
127 -- which they will be read and
152 -- which they will be read and
128 -- processed.
153 -- processed.
129
154
130− flip runReaderT displayRegion0 $
155+ vtyGuest displayRegion0 vtyEvent
131− vtyGuest vtyEvent -- The guest app is provided an
156+ -- The guest app is provided the
157+ -- initial display region and an
132 -- 'Event' of vty inputs.
158 -- 'Event' of vty inputs.
133
159
134 -- Reads the current value of the 'Picture' behavior and updates the
160 -- Reads the current value of the 'Picture' behavior and updates the
@@ -220,3 +246,162 @@ runVtyApp app = do
220 cfg <- liftIO V.standardIOConfig
246 cfg <- liftIO V.standardIOConfig
221 vty <- liftIO $ V.mkVty $ cfg { V.mouseMode = Just True }
247 vty <- liftIO $ V.mkVty $ cfg { V.mouseMode = Just True }
222 runVtyAppWith vty app
248 runVtyAppWith vty app
249+
250+
251+---- Widget.hs
252+
253+data Region = Region
254+ { _region_left :: Int
255+ , _region_top :: Int
256+ , _region_width :: Int
257+ , _region_height :: Int
258+ }
259+ deriving (Show, Read, Eq, Ord)
260+
261+regionToDisplayRegion :: Region -> DisplayRegion
262+regionToDisplayRegion (Region _ _ w h) = (w, h)
263+
264+region :: Region -> (DisplayRegion -> Image) -> [Image]
265+region r@(Region _ _ width height) i =
266+ [ within r $ V.resize width height $ i (width, height)
267+ , within r $ wrapString width V.defAttr $ replicate (width * height) ' '
268+ ]
269+
270+within :: Region -> Image -> Image
271+within (Region left top width height) =
272+ V.translate left top . V.crop width height
273+
274+wrapString :: Int -> Attr -> String -> Image
275+wrapString maxWidth attrs = V.vertCat . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
276+
277+box :: Region -> (DisplayRegion -> Image) -> [Image]
278+box r@(Region left top width height) i =
279+ let hBorder = V.string mempty $ replicate width '-'
280+ 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
288+ , within (Region left (top + 1) 1 (height - 2)) vBorder
289+ , within (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
290+ , within (r { _region_top = top + height - 1 }) hBorder
291+ ] ++ region internal i
292+
293+class HasDisplaySize t m | m -> t where
294+ displaySize :: m (Dynamic t (Int, Int))
295+
296+class HasVtyInput t m | m -> t where
297+ input :: m (Event t VtyEvent)
298+
299+class HasFocus t m | m -> t where
300+ focus :: m (Dynamic t Bool)
301+
302+data VtyWidgetCtx t = VtyWidgetCtx
303+ { _vtyWidgetCtx_size :: Dynamic t (Int,Int) -- ^ The width and height of the region allocated to the widget.
304+ , _vtyWidgetCtx_focus :: Dynamic t Bool -- ^ Whether the widget should behave as if it has focus for keyboard input.
305+ , _vtyWidgetCtx_input :: Event t VtyEvent -- ^ User input events that the widget's parent chooses to share. These will generally
306+ -- be filtered for relevance:
307+ -- * Keyboard inputs are restricted to focused widgets
308+ -- * Mouse inputs are restricted to the region in which the widget resides.
309+ }
310+
311+data VtyWidgetOut t = VtyWidgetOut
312+ { _vtyWidgetOut_images :: Behavior t [Image]
313+ , _vtyWidgetOut_shutdown :: Event t ()
314+ }
315+
316+instance (Reflex t) => Semigroup (VtyWidgetOut t) where
317+ wo <> wo' = VtyWidgetOut
318+ { _vtyWidgetOut_images = _vtyWidgetOut_images wo <> _vtyWidgetOut_images wo'
319+ , _vtyWidgetOut_shutdown = _vtyWidgetOut_shutdown wo <> _vtyWidgetOut_shutdown wo'
320+ }
321+
322+instance (Reflex t) => Monoid (VtyWidgetOut t) where
323+ mempty = VtyWidgetOut mempty mempty
324+ mappend wo wo' = wo <> wo'
325+
326+newtype VtyWidget t m a = VtyWidget { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a }
327+ deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t)
328+
329+runVtyWidget :: (MonadFix m, Reflex t)
330+ => VtyWidgetCtx t
331+ -> VtyWidget t m a
332+ -> m (a, VtyWidgetOut t)
333+runVtyWidget ctx w = runReaderT (runWriterT (unVtyWidget w)) ctx
334+
335+mainVtyWidget :: (forall t m. MonadVtyApp t m => VtyWidget t m ()) -> IO ()
336+mainVtyWidget child =
337+ runVtyApp $ \dr0 inp -> do
338+ size <- holdDyn dr0 $ fforMaybe inp $ \case
339+ V.EvResize w h -> Just (w, h)
340+ _ -> Nothing
341+ let ctx = VtyWidgetCtx
342+ { _vtyWidgetCtx_size = size
343+ , _vtyWidgetCtx_input = inp
344+ , _vtyWidgetCtx_focus = constDyn True
345+ }
346+ ((), wo) <- runVtyWidget ctx child
347+ return $ VtyResult
348+ { _vtyResult_picture = fmap V.picForLayers (_vtyWidgetOut_images wo)
349+ , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo
350+ }
351+
352+modifyImages :: (Reflex t, MonadHold t m, MonadFix m)
353+ => Behavior t ([Image] -> [Image]) -> VtyWidget t m a -> VtyWidget t m a
354+modifyImages f (VtyWidget w) = VtyWidget $
355+ censor (\wo -> wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) })
356+ w
357+
358+instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
359+ displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size
360+
361+instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
362+ input = VtyWidget . lift $ asks _vtyWidgetCtx_input
363+
364+instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
365+ focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
366+
367+tellImages :: (Reflex t, Monad m) => Behavior t [Image] -> VtyWidget t m ()
368+tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })
369+
370+tellShutdown :: (Reflex t, Monad m) => Event t () -> VtyWidget t m ()
371+tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })
372+
373+pane :: (MonadFix m, Reflex t)
374+ => 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
376+ -> VtyWidget t m a
377+ -> VtyWidget t m a
378+pane reg foc w = VtyWidget $ do
379+ ctx <- lift ask
380+ let ctx' = VtyWidgetCtx
381+ { _vtyWidgetCtx_input = fmapMaybe id $
382+ attachWith (\(r,f) e -> filterInput r f e)
383+ (liftA2 (,) (current reg) (current foc))
384+ (_vtyWidgetCtx_input ctx)
385+ , _vtyWidgetCtx_focus = foc
386+ , _vtyWidgetCtx_size = fmap regionToDisplayRegion reg }
387+ (result, wo) <- lift . lift $ runVtyWidget ctx' w
388+ let images = _vtyWidgetOut_images wo
389+ images' = liftA2 (\r is -> map (within r) is) (current reg) images
390+ wo' = wo { _vtyWidgetOut_images = images' }
391+ tell wo'
392+ return result
393+
394+filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
395+filterInput r focused e = case e of
396+ V.EvKey _ _ | not focused -> Nothing
397+ 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
399+ _ -> Just e
400+ where
401+ mouse con x y
402+ | or [ x < 0
403+ , y < 0
404+ , x >= _region_width r
405+ , y >= _region_height r ] = Nothing
406+ | otherwise =
407+ Just (con (x + _region_left r) (y + _region_top r))