@@ -5,15 +5,39 @@
55{-# LANGUAGE RankNTypes #-}
66{-# LANGUAGE ScopedTypeVariables #-}
77{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE ConstraintKinds #-}
11+
12+{-# OPTIONS_GHC -Wall #-}
813
914module Reflex.Vty
1015 ( VtyApp
1116 , VtyResult(..)
17+ , VtyEvent
1218 , runVtyApp
1319 , 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
1538 ) where
1639
40+import Control.Applicative
1741import Control.Concurrent (forkIO, killThread)
1842import Control.Concurrent.Chan (newChan, readChan, writeChan)
1943import Control.Monad (forM, forM_, forever)
@@ -23,6 +47,8 @@ import Control.Monad.Identity (Identity(..))
2347import Control.Monad.Primitive (PrimMonad)
2448import Control.Monad.Ref (MonadRef, Ref, readRef)
2549import Control.Monad.Trans.Reader
50+import Control.Monad.Trans.Writer
51+import Control.Monad.Trans
2652import Data.Dependent.Sum (DSum ((:=>)))
2753import Data.IORef (IORef)
2854import Data.IORef (readIORef)
@@ -33,6 +59,9 @@ import Reflex.Host.Class
3359import Reflex.NotReady.Class
3460import Reflex.Spider.Orphans ()
3561import qualified Graphics.Vty as V
62+import Graphics.Vty (DisplayRegion, Image, Attr)
63+
64+type VtyEvent = V.Event
3665
3766-- | The output of a 'VtyApp'.
3867data VtyResult t = VtyResult
@@ -43,14 +72,7 @@ data VtyResult t = VtyResult
4372 -- ^ An event that requests application termination.
4473 }
4574
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 =
5476 ( Reflex t
5577 , MonadHold t m
5678 , MonadFix m
@@ -66,10 +88,13 @@ type VtyApp t m =
6688 , PerformEvent t m
6789 , MonadIO m
6890 , MonadIO (Performable m)
69−
70− , HasDisplayRegion m
7191 )
72− => Event t (V.Event)
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)
97+ -> Event t (V.Event)
7398 -- ^ Vty input events.
7499 -> m (VtyResult t)
75100 -- ^ The output of the 'VtyApp'. The application runs in a context that,
@@ -127,8 +152,9 @@ runVtyAppWith vty vtyGuest =
127152 -- which they will be read and
128153 -- processed.
129154
130− flip runReaderT displayRegion0 $
131− vtyGuest vtyEvent -- The guest app is provided an
155+ vtyGuest displayRegion0 vtyEvent
156+ -- The guest app is provided the
157+ -- initial display region and an
132158 -- 'Event' of vty inputs.
133159
134160 -- Reads the current value of the 'Picture' behavior and updates the
@@ -220,3 +246,162 @@ runVtyApp app = do
220246 cfg <- liftIO V.standardIOConfig
221247 vty <- liftIO $ V.mkVty $ cfg { V.mouseMode = Just True }
222248 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))