@@ -1,510 +1,7 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE FunctionalDependencies #-}
9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10−{-# LANGUAGE ConstraintKinds #-}
11−{-# LANGUAGE RecursiveDo #-}
12−
13−{-# OPTIONS_GHC -Wall #-}
14−
151module Reflex.Vty
16− ( VtyApp
17− , VtyResult(..)
18− , VtyEvent
19− , runVtyApp
20− , runVtyAppWith
21− , HasDisplaySize(..)
22− , displayWidth
23− , displayHeight
24− , HasFocus(..)
25− , HasVtyInput(..)
26− , Region(..)
27− , regionSize
28− , regionBlankImage
29− , boxImages
30− , runVtyWidget
31− , VtyWidgetCtx(..)
32− , VtyWidget(..)
33− , VtyWidgetOut(..)
34− , Drag (..)
35− , drag
36− , pane
37− , modifyImages
38− , mainVtyWidget
39− , filterInput
40− , tellImages
41− , tellShutdown
42− , wrapString
43− , splitV
44− , fractionSz
45− , box
46− , string
2+ ( module Reflex.Vty.Host
3+ , module Reflex.Vty.Widget
474 ) where
485
49−import Control.Applicative
50−import Control.Concurrent (forkIO, killThread)
51−import Control.Concurrent.Chan (newChan, readChan, writeChan)
52−import Control.Monad (forM, forM_, forever)
53−import Control.Monad.Fix (MonadFix, fix)
54−import Control.Monad.IO.Class (liftIO, MonadIO)
55−import Control.Monad.Identity (Identity(..))
56−import Control.Monad.Primitive (PrimMonad)
57−import Control.Monad.Ref (MonadRef, Ref, readRef)
58−import Control.Monad.Trans.Reader
59−import Control.Monad.Trans.Writer
60−import Control.Monad.Trans
61−import Data.Dependent.Sum (DSum ((:=>)))
62−import Data.IORef (IORef)
63−import Data.IORef (readIORef)
64−import Data.Maybe (catMaybes)
65−
66−import Reflex
67−import Reflex.Host.Class
68−import Reflex.NotReady.Class
69−import Reflex.Spider.Orphans ()
70−import qualified Graphics.Vty as V
71−import Graphics.Vty (DisplayRegion, Image, Attr)
72−
73−type VtyEvent = V.Event
74−
75−-- | The output of a 'VtyApp'.
76−data VtyResult t = VtyResult
77− { _vtyResult_picture :: Behavior t V.Picture
78− -- ^ The current vty output. 'runVtyAppWith' samples this value every time an
79− -- event fires and updates the display.
80− , _vtyResult_shutdown :: Event t ()
81− -- ^ An event that requests application termination.
82− }
83−
84−type MonadVtyApp t m =
85− ( Reflex t
86− , MonadHold t m
87− , MonadFix m
88− , PrimMonad (HostFrame t)
89− , ReflexHost t
90− , MonadIO (HostFrame t)
91− , Ref m ~ IORef
92− , Ref (HostFrame t) ~ IORef
93− , MonadRef (HostFrame t)
94− , NotReady t m
95− , TriggerEvent t m
96− , PostBuild t m
97− , PerformEvent t m
98− , MonadIO m
99− , MonadIO (Performable m)
100− )
101−
102−-- | A functional reactive vty application.
103−type VtyApp t m = MonadVtyApp t m
104− => DisplayRegion
105− -- ^ The initial display size (updates to this come as events)
106− -> Event t (V.Event)
107− -- ^ Vty input events.
108− -> m (VtyResult t)
109− -- ^ The output of the 'VtyApp'. The application runs in a context that,
110− -- among other things, allows new events to be created and triggered
111− -- ('TriggerEvent'), provides access to an event that fires immediately upon
112− -- app instantiation ('PostBuild'), and allows actions to be run upon
113− -- occurrences of events ('PerformEvent').
114−
115−-- | Runs a 'VtyApp' in a given 'Vty'.
116−runVtyAppWith
117− :: V.Vty
118− -- ^ A 'Vty' handle.
119− -> (forall t m. VtyApp t m)
120− -- ^ A functional reactive vty application.
121− -> IO ()
122−runVtyAppWith vty vtyGuest =
123− -- We are using the 'Spider' implementation of reflex. Running the host
124− -- allows us to take actions on the FRP timeline. The scoped type signature
125− -- specifies that our host runs on the Global timeline.
126− -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'.
127− (runSpiderHost :: SpiderHost Global a -> IO a) $ do
128−
129− -- Create an 'Event' and a "trigger" reference for that event. The trigger
130− -- reference can be used to determine whether anyone is "subscribed" to
131− -- that 'Event' and, therefore, whether we need to bother performing any
132− -- updates when the 'Event' fires.
133− -- The 'Event' below will be used to convey vty input events.
134− (vtyEvent, vtyEventTriggerRef) <- newEventWithTriggerRef
135−
136− -- Create the "post-build" event and associated trigger. This event fires
137− -- once, when the application starts.
138− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
139−
140− -- Create a queue to which we will write 'Event's that need to be
141− -- processed.
142− events <- liftIO newChan
143−
144− displayRegion0 <- V.displayBounds $ V.outputIface vty
145−
146− -- Run the vty "guest" application, providing the appropriate context. The
147− -- result is a 'VtyResult', and a 'FireCommand' that will be used to
148− -- trigger events.
149− (vtyResult, fc@(FireCommand fire)) <- do
150− hostPerformEventT $ -- Allows the guest app to run
151− -- 'performEvent', so that actions
152− -- (e.g., IO actions) can be run when
153− -- 'Event's fire.
154−
155− flip runPostBuildT postBuild $ -- Allows the guest app to access to
156− -- a "post-build" 'Event'
157−
158− flip runTriggerEventT events $ -- Allows the guest app to create new
159− -- events and triggers and writes
160− -- those triggers to a channel from
161− -- which they will be read and
162− -- processed.
163−
164− vtyGuest displayRegion0 vtyEvent
165− -- The guest app is provided the
166− -- initial display region and an
167− -- 'Event' of vty inputs.
168−
169− -- Reads the current value of the 'Picture' behavior and updates the
170− -- display with it. This will be called whenever we determine that a
171− -- display update is necessary. In this implementation that is when various
172− -- events occur.
173− let updateVty =
174− sample (_vtyResult_picture vtyResult) >>= liftIO . V.update vty
175−
176− -- Read the trigger reference for the post-build event. This will be
177− -- 'Nothing' if the guest application hasn't subscribed to this event.
178− mPostBuildTrigger <- readRef postBuildTriggerRef
179−
180− -- When there is a subscriber to the post-build event, fire the event.
181− forM_ mPostBuildTrigger $ \postBuildTrigger ->
182− fire [postBuildTrigger :=> Identity ()] $ return ()
183−
184− -- After firing the post-build event, sample the vty result and update
185− -- the display.
186− updateVty
187−
188− -- Subscribe to an 'Event' of that the guest application can use to
189− -- request application shutdown. We'll check whether this 'Event' is firing
190− -- to determine whether to terminate.
191− shutdown <- subscribeEvent $ _vtyResult_shutdown vtyResult
192−
193− -- Fork a thread and continuously get the next vty input event, and then
194− -- write the input event to our channel of FRP 'Event' triggers.
195− -- The thread is forked here because 'nextEvent' blocks.
196− nextEventThread <- liftIO $ forkIO $ forever $ do
197− -- Retrieve the next input event.
198− ne <- V.nextEvent vty
199− let -- The reference to the vty input 'EventTrigger'. This is the trigger
200− -- we'd like to associate the input event value with.
201− triggerRef = EventTriggerRef vtyEventTriggerRef
202− -- Create an event 'TriggerInvocation' with the value that we'd like
203− -- the event to have if it is fired. It may not fire with this value
204− -- if nobody is subscribed to the 'Event'.
205− triggerInvocation = TriggerInvocation ne $ return ()
206− -- Write our input event's 'EventTrigger' with the newly created
207− -- 'TriggerInvocation' value to the queue of events.
208− writeChan events $ [triggerRef :=> triggerInvocation]
209−
210− -- The main application loop. We wait for new events, fire those that
211− -- have subscribers, and update the display. If we detect a shutdown
212− -- request, the application terminates.
213− fix $ \loop -> do
214− -- Read the next event (blocking).
215− ers <- liftIO $ readChan events
216− stop <- do
217− -- Fire events that have subscribers.
218− fireEventTriggerRefs fc ers $
219− -- Check if the shutdown 'Event' is firing.
220− readEvent shutdown >>= \case
221− Nothing -> return False
222− Just _ -> return True
223− if or stop
224− then liftIO $ do -- If we received a shutdown 'Event'
225− killThread nextEventThread -- then stop reading input events and
226− V.shutdown vty -- call the 'Vty's shutdown command.
227−
228− else do -- Otherwise, update the display and loop.
229− updateVty
230− loop
231− where
232− -- TODO Some part of this is probably general enough to belong in reflex
233− -- | Use the given 'FireCommand' to fire events that have subscribers
234− -- and call the callback for the 'TriggerInvocation' of each.
235− fireEventTriggerRefs
236− :: (Monad (ReadPhase m), MonadIO m)
237− => FireCommand t m
238− -> [DSum (EventTriggerRef t) TriggerInvocation]
239− -> ReadPhase m a
240− -> m [a]
241− fireEventTriggerRefs (FireCommand fire) ers rcb = do
242− mes <- liftIO $
243− forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
244− me <- readIORef er
245− return $ fmap (\e -> e :=> Identity a) me
246− a <- fire (catMaybes mes) rcb
247− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
248− return a
249−
250−-- | Run a 'VtyApp' with a 'Vty' handle with a standard configuration.
251−runVtyApp
252− :: (forall t m. VtyApp t m)
253− -> IO ()
254−runVtyApp app = do
255− cfg <- liftIO V.standardIOConfig
256− vty <- liftIO $ V.mkVty $ cfg { V.mouseMode = Just True }
257− runVtyAppWith vty app
258−
259−
260−---- Widget.hs
261−
262−data Region = Region
263− { _region_left :: Int
264− , _region_top :: Int
265− , _region_width :: Int
266− , _region_height :: Int
267− }
268− deriving (Show, Read, Eq, Ord)
269−
270−regionSize :: Region -> (Int, Int)
271−regionSize (Region _ _ w h) = (w, h)
272−
273−regionBlankImage :: Region -> Image
274−regionBlankImage r@(Region _ _ width height) =
275− withinImage r $ wrapString width V.defAttr $ replicate (width * height) ' '
276−
277−withinImage :: Region -> Image -> Image
278−withinImage (Region left top width height)
279− | width < 0 || height < 0 = withinImage (Region left top 0 0)
280− | otherwise = V.translate left top . V.crop width height
281−
282−wrapString :: Int -> Attr -> String -> Image
283−wrapString maxWidth attrs = V.vertCat . concatMap (fmap (V.string attrs) . fmap (take maxWidth) . takeWhile (not . null) . iterate (drop maxWidth)) . lines
284−
285−boxImages :: Region -> [Image]
286−boxImages r@(Region left top width height) =
287− let hBorder = V.string mempty $ replicate width '-'
288− vBorder = wrapString 1 mempty $ replicate (height - 2) '|'
289− in [ withinImage (r { _region_height = 1 }) hBorder
290− , withinImage (Region left (top + 1) 1 (height - 2)) vBorder
291− , withinImage (Region (left + width - 1) (top + 1) 1 (height - 2)) vBorder
292− , withinImage (r { _region_top = top + height - 1 }) hBorder
293− ]
294−
295−class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
296− displaySize :: m (Dynamic t (Int, Int))
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−
304−class HasVtyInput t m | m -> t where
305− input :: m (Event t VtyEvent)
306−
307−class HasFocus t m | m -> t where
308− focus :: m (Dynamic t Bool)
309−
310−data VtyWidgetCtx t = VtyWidgetCtx
311− { _vtyWidgetCtx_size :: Dynamic t (Int,Int) -- ^ The width and height of the region allocated to the widget.
312− , _vtyWidgetCtx_focus :: Dynamic t Bool -- ^ Whether the widget should behave as if it has focus for keyboard input.
313− , _vtyWidgetCtx_input :: Event t VtyEvent -- ^ User input events that the widget's parent chooses to share. These will generally
314− -- be filtered for relevance:
315− -- * Keyboard inputs are restricted to focused widgets
316− -- * Mouse inputs are restricted to the region in which the widget resides.
317− }
318−
319−data VtyWidgetOut t = VtyWidgetOut
320− { _vtyWidgetOut_images :: Behavior t [Image]
321− , _vtyWidgetOut_shutdown :: Event t ()
322− }
323−
324−instance (Reflex t) => Semigroup (VtyWidgetOut t) where
325− wo <> wo' = VtyWidgetOut
326− { _vtyWidgetOut_images = _vtyWidgetOut_images wo <> _vtyWidgetOut_images wo'
327− , _vtyWidgetOut_shutdown = _vtyWidgetOut_shutdown wo <> _vtyWidgetOut_shutdown wo'
328− }
329−
330−instance (Reflex t) => Monoid (VtyWidgetOut t) where
331− mempty = VtyWidgetOut mempty mempty
332− mappend wo wo' = wo <> wo'
333−
334−newtype VtyWidget t m a = VtyWidget { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a }
335− deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix)
336−
337−runVtyWidget :: (Reflex t)
338− => VtyWidgetCtx t
339− -> VtyWidget t m a
340− -> m (a, VtyWidgetOut t)
341−runVtyWidget ctx w = runReaderT (runWriterT (unVtyWidget w)) ctx
342−
343−mainVtyWidget :: (forall t m. MonadVtyApp t m => VtyWidget t m ()) -> IO ()
344−mainVtyWidget child =
345− runVtyApp $ \dr0 inp -> do
346− size <- holdDyn dr0 $ fforMaybe inp $ \case
347− V.EvResize w h -> Just (w, h)
348− _ -> Nothing
349− let ctx = VtyWidgetCtx
350− { _vtyWidgetCtx_size = size
351− , _vtyWidgetCtx_input = inp
352− , _vtyWidgetCtx_focus = constDyn True
353− }
354− ((), wo) <- runVtyWidget ctx child
355− return $ VtyResult
356− { _vtyResult_picture = fmap (V.picForLayers . reverse) (_vtyWidgetOut_images wo)
357− , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo
358− }
359−
360−modifyImages :: (Reflex t, MonadHold t m, MonadFix m)
361− => Behavior t ([Image] -> [Image]) -> VtyWidget t m a -> VtyWidget t m a
362−modifyImages f (VtyWidget w) = VtyWidget $
363− censor (\wo -> wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) })
364− w
365−
366−instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
367− displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size
368−
369−instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
370− input = VtyWidget . lift $ asks _vtyWidgetCtx_input
371−
372−instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
373− focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
374−
375−tellImages :: (Reflex t, Monad m) => Behavior t [Image] -> VtyWidget t m ()
376−tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })
377−
378−tellShutdown :: (Reflex t, Monad m) => Event t () -> VtyWidget t m ()
379−tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })
380−
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)
414− => Dynamic t Region -- ^ Region into which we should draw the widget (in coordinates relative to our own)
415− -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
416− -> VtyWidget t m a
417− -> VtyWidget t m a
418−pane reg foc child = VtyWidget $ do
419− ctx <- lift ask
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
423− , fmapMaybe id $
424− attachWith (\(r,f) e -> filterInput r f e)
425− (liftA2 (,) (current reg) (current foc))
426− (_vtyWidgetCtx_input ctx)
427− ]
428− , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
429− , _vtyWidgetCtx_size = fmap regionSize reg }
430− (result, wo) <- lift . lift $ runVtyWidget ctx' child
431− let images = _vtyWidgetOut_images wo
432− images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images
433− wo' = wo { _vtyWidgetOut_images = images' }
434− tell wo'
435− return result
436−
437−filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
438−filterInput (Region l t w h) focused e = case e of
439− V.EvKey _ _ | not focused -> Nothing
440− V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
441− V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
442− _ -> Just e
443− where
444− mouse con x y
445− | or [ x < l
446− , y < t
447− , x >= l + w
448− , y >= t + h ] = Nothing
449− | otherwise =
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
6+import Reflex.Vty.Host
7+import Reflex.Vty.Widget