@@ -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 #-}
13−{-# OPTIONS_GHC -Wall #-}
15module Reflex.Vty
1module Reflex.Vty
16− ( VtyApp
2+ ( module Reflex.Vty.Host
17− , VtyResult(..)
3+ , module Reflex.Vty.Widget
49−import Control.Applicative
6+import Reflex.Vty.Host
50−import Control.Concurrent (forkIO, killThread)
7+import Reflex.Vty.Widget
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)
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)
73−type VtyEvent = V.Event
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.
84−type MonadVtyApp t m =
88− , PrimMonad (HostFrame t)
90− , MonadIO (HostFrame t)
92− , Ref (HostFrame t) ~ IORef
93− , MonadRef (HostFrame t)
99− , MonadIO (Performable m)
102−-- | A functional reactive vty application.
103−type VtyApp t m = MonadVtyApp t m
105− -- ^ The initial display size (updates to this come as events)
106− -> Event t (V.Event)
107− -- ^ Vty input events.
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').
115−-- | Runs a 'VtyApp' in a given 'Vty'.
118− -- ^ A 'Vty' handle.
119− -> (forall t m. VtyApp t m)
120− -- ^ A functional reactive vty application.
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
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
136− -- Create the "post-build" event and associated trigger. This event fires
137− -- once, when the application starts.
138− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
140− -- Create a queue to which we will write 'Event's that need to be
142− events <- liftIO newChan
144− displayRegion0 <- V.displayBounds $ V.outputIface vty
146− -- Run the vty "guest" application, providing the appropriate context. The
147− -- result is a 'VtyResult', and a 'FireCommand' that will be used to
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
155− flip runPostBuildT postBuild $ -- Allows the guest app to access to
156− -- a "post-build" 'Event'
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
164− vtyGuest displayRegion0 vtyEvent
165− -- The guest app is provided the
166− -- initial display region and an
167− -- 'Event' of vty inputs.
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
174− sample (_vtyResult_picture vtyResult) >>= liftIO . V.update vty
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
180− -- When there is a subscriber to the post-build event, fire the event.
181− forM_ mPostBuildTrigger $ \postBuildTrigger ->
182− fire [postBuildTrigger :=> Identity ()] $ return ()
184− -- After firing the post-build event, sample the vty result and update
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
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]
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.
214− -- Read the next event (blocking).
215− ers <- liftIO $ readChan events
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
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.
228− else do -- Otherwise, update the display and loop.
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)
238− -> [DSum (EventTriggerRef t) TriggerInvocation]
241− fireEventTriggerRefs (FireCommand fire) ers rcb = do
243− forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
245− return $ fmap (\e -> e :=> Identity a) me
246− a <- fire (catMaybes mes) rcb
247− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
250−-- | Run a 'VtyApp' with a 'Vty' handle with a standard configuration.
252− :: (forall t m. VtyApp t m)
255− cfg <- liftIO V.standardIOConfig
256− vty <- liftIO $ V.mkVty $ cfg { V.mouseMode = Just True }
257− runVtyAppWith vty app
263− { _region_left :: Int
264− , _region_top :: Int
265− , _region_width :: Int
266− , _region_height :: Int
268− deriving (Show, Read, Eq, Ord)
270−regionSize :: Region -> (Int, Int)
271−regionSize (Region _ _ w h) = (w, h)
273−regionBlankImage :: Region -> Image
274−regionBlankImage r@(Region _ _ width height) =
275− withinImage r $ wrapString width V.defAttr $ replicate (width * height) ' '
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
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
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
295−class (Reflex t, Monad m) => HasDisplaySize t m | m -> t where
296− displaySize :: m (Dynamic t (Int, Int))
298−displayWidth :: HasDisplaySize t m => m (Dynamic t Int)
299−displayWidth = fmap fst <$> displaySize
301−displayHeight :: HasDisplaySize t m => m (Dynamic t Int)
302−displayHeight = fmap snd <$> displaySize
304−class HasVtyInput t m | m -> t where
305− input :: m (Event t VtyEvent)
307−class HasFocus t m | m -> t where
308− focus :: m (Dynamic t Bool)
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.
319−data VtyWidgetOut t = VtyWidgetOut
320− { _vtyWidgetOut_images :: Behavior t [Image]
321− , _vtyWidgetOut_shutdown :: Event t ()
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'
330−instance (Reflex t) => Monoid (VtyWidgetOut t) where
331− mempty = VtyWidgetOut mempty mempty
332− mappend wo wo' = wo <> wo'
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)
337−runVtyWidget :: (Reflex t)
340− -> m (a, VtyWidgetOut t)
341−runVtyWidget ctx w = runReaderT (runWriterT (unVtyWidget w)) ctx
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)
349− let ctx = VtyWidgetCtx
350− { _vtyWidgetCtx_size = size
351− , _vtyWidgetCtx_input = inp
352− , _vtyWidgetCtx_focus = constDyn True
354− ((), wo) <- runVtyWidget ctx child
356− { _vtyResult_picture = fmap (V.picForLayers . reverse) (_vtyWidgetOut_images wo)
357− , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo
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) })
366−instance (Reflex t, Monad m) => HasDisplaySize t (VtyWidget t m) where
367− displaySize = VtyWidget . lift $ asks _vtyWidgetCtx_size
369−instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
370− input = VtyWidget . lift $ asks _vtyWidgetCtx_input
372−instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
373− focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
375−tellImages :: (Reflex t, Monad m) => Behavior t [Image] -> VtyWidget t m ()
376−tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })
378−tellShutdown :: (Reflex t, Monad m) => Event t () -> VtyWidget t m ()
379−tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })
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)
388− deriving (Eq, Ord, Show)
390−drag :: (Reflex t, MonadFix m, MonadHold t m) => V.Button -> VtyWidget t m (Event t Drag)
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')
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.
406− | otherwise -> Just $ Drag from (x,y) btn mods True
408− rec let newDrag = attachWithMaybe f (current dragD) inp
409− dragD <- holdDyn (Drag (0,0) (0,0) V.BLeft [] True) -- gross, but ok.
411− return (updated dragD)
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.
418−pane reg foc child = VtyWidget $ do
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
424− attachWith (\(r,f) e -> filterInput r f e)
425− (liftA2 (,) (current reg) (current foc))
426− (_vtyWidgetCtx_input ctx)
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' }
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
448− , y >= t + h ] = Nothing
450− Just (con (x - l) (y - t))
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.
460− -- ^ Widget for first pane
462− -- ^ Widget for second pane
463− -> VtyWidget t m (a,b)
464−splitV sizeFunD focD wA wB = do
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
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.
478−splitVDrag :: (Reflex t, Monad m)
481− -> VtyWidget t m (a,b)
482−splitVDrag wA wB = do
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
492−fractionSz :: Double -> Int -> Int
493−fractionSz x h = round (fromIntegral h * x)
495−box :: (Monad m, Reflex t)
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
506−string :: (Reflex t, Monad m) => Behavior t String -> VtyWidget t m ()
509− let img = (\w s -> [wrapString w mempty s]) <$> current dw <*> msg