@@ -0,0 +1,284 @@
1+{-|
2+Module: Reflex.Vty.Widget.Layout
3+Description: Monad transformer and tools for arranging widgets and building screen layouts
4+-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE RecursiveDo #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+
12+module Reflex.Vty.Widget.Layout
13+ ( Orientation(..)
14+ , Constraint(..)
15+ , Layout
16+ , runLayout
17+ , TileConfig(..)
18+ , tile
19+ , fixed
20+ , stretch
21+ , col
22+ , row
23+ , tabNavigation
24+ , askOrientation
25+ ) where
26+
27+import Control.Monad.NodeId (NodeId, MonadNodeId(..))
28+import Control.Monad.Reader
29+import Data.Bimap (Bimap)
30+import qualified Data.Bimap as Bimap
31+import Data.Default (Default(..))
32+import Data.Map (Map)
33+import qualified Data.Map as Map
34+import Data.Maybe (fromMaybe)
35+import Data.Monoid hiding (First(..))
36+import Data.Ratio ((%))
37+import Data.Semigroup (First(..))
38+import qualified Graphics.Vty as V
39+
40+import Reflex
41+import Reflex.Host.Class (MonadReflexCreateTrigger)
42+import Reflex.Vty.Widget
43+
44+-- | The main-axis orientation of a 'Layout' widget
45+data Orientation = Orientation_Column
46+ | Orientation_Row
47+ deriving (Show, Read, Eq, Ord)
48+
49+data LayoutSegment = LayoutSegment
50+ { _layoutSegment_offset :: Int
51+ , _layoutSegment_size :: Int
52+ }
53+
54+data LayoutCtx t = LayoutCtx
55+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
56+ , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)
57+ , _layoutCtx_orientation :: Dynamic t Orientation
58+ }
59+
60+-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
61+-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
62+-- switchboard for focus requests. See 'tile' and 'runLayout'.
63+newtype Layout t m a = Layout
64+ { unLayout :: EventWriterT t (First NodeId)
65+ (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))])
66+ (ReaderT (LayoutCtx t)
67+ (VtyWidget t m))) a
68+ } deriving
69+ ( Functor
70+ , Applicative
71+ , Monad
72+ , MonadHold t
73+ , MonadSample t
74+ , MonadFix
75+ , TriggerEvent t
76+ , PerformEvent t
77+ , NotReady t
78+ , MonadReflexCreateTrigger t
79+ , HasDisplaySize t
80+ , MonadNodeId
81+ )
82+
83+instance MonadTrans (Layout t) where
84+ lift x = Layout $ lift $ lift $ lift $ lift x
85+
86+instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
87+ runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
88+ traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
89+ traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
90+ traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
91+
92+-- | Run a 'Layout' action
93+runLayout
94+ :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
95+ => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
96+ -> Int -- ^ The positional index of the initially focused tile
97+ -> Event t Int -- ^ An event that shifts focus by a given number of tiles
98+ -> Layout t m a -- ^ The 'Layout' widget
99+ -> VtyWidget t m a
100+runLayout ddir focus0 focusShift (Layout child) = do
101+ dw <- displayWidth
102+ dh <- displayHeight
103+ let main = ffor3 ddir dw dh $ \d w h -> case d of
104+ Orientation_Column -> h
105+ Orientation_Row -> w
106+ pb <- getPostBuild
107+ rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir
108+ let queries = flip appEndo [] <$> queriesEndo
109+ solution = ffor2 main queries $ \sz qs -> Map.fromList
110+ . Map.elems
111+ . computeEdges
112+ . computeSizes sz
113+ . fmap (fmap snd)
114+ . Map.fromList
115+ . zip [0::Integer ..]
116+ $ qs
117+ solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
118+ { _layoutSegment_offset = offset
119+ , _layoutSegment_size = sz
120+ }
121+ focusable = fmap (Bimap.fromList . zip [0..]) $
122+ ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
123+ if f then Just nodeId else Nothing
124+ adjustFocus
125+ :: (Bimap Int NodeId, (Int, Maybe NodeId))
126+ -> Either Int NodeId
127+ -> (Int, Maybe NodeId)
128+ adjustFocus (fm, (cur, _)) (Left shift) =
129+ let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
130+ in (ix, Bimap.lookup ix fm)
131+ adjustFocus (fm, (cur, _)) (Right goto) =
132+ let ix = fromMaybe cur $ Bimap.lookupR goto fm
133+ in (ix, Just goto)
134+ focusChange = attachWith
135+ adjustFocus
136+ (current $ (,) <$> focusable <*> focussed)
137+ $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
138+ -- A pair (Int, Maybe NodeId) which represents the index
139+ -- that we're trying to focus, and the node that actually gets
140+ -- focused (at that index) if it exists
141+ focussed <- holdDyn (focus0, Nothing) focusChange
142+ let focusDemux = demux $ snd <$> focussed
143+ return a
144+
145+-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
146+-- on its size and ability to grow and on whether it can be focused. It also allows its child
147+-- widget to request focus.
148+tile
149+ :: (Reflex t, Monad m, MonadNodeId m)
150+ => TileConfig t -- ^ The tile's configuration
151+ -> VtyWidget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
152+ -> Layout t m a
153+tile (TileConfig con focusable) child = do
154+ nodeId <- getNextNodeId
155+ Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)
156+ seg <- Layout $ asks $
157+ fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
158+ dw <- displayWidth
159+ dh <- displayHeight
160+ o <- askOrientation
161+ let cross = join $ ffor o $ \case
162+ Orientation_Column -> dw
163+ Orientation_Row -> dh
164+ let reg = DynRegion
165+ { _dynRegion_top = ffor2 seg o $ \s -> \case
166+ Orientation_Column -> _layoutSegment_offset s
167+ Orientation_Row -> 0
168+ , _dynRegion_left = ffor2 seg o $ \s -> \case
169+ Orientation_Column -> 0
170+ Orientation_Row -> _layoutSegment_offset s
171+ , _dynRegion_width = ffor3 seg cross o $ \s c -> \case
172+ Orientation_Column -> c
173+ Orientation_Row -> _layoutSegment_size s
174+ , _dynRegion_height = ffor3 seg cross o $ \s c -> \case
175+ Orientation_Column -> _layoutSegment_size s
176+ Orientation_Row -> c
177+ }
178+ focussed <- Layout $ asks _layoutCtx_focusDemux
179+ (focusReq, a) <- Layout $ lift $ lift $ lift $
180+ pane reg (demuxed focussed $ Just nodeId) $ child
181+ Layout $ tellEvent $ First nodeId <$ focusReq
182+ return a
183+
184+-- | Configuration options for and constraints on 'tile'
185+data TileConfig t = TileConfig
186+ { _tileConfig_constraint :: Dynamic t Constraint
187+ -- ^ 'Constraint' on the tile's size
188+ , _tileConfig_focusable :: Dynamic t Bool
189+ -- ^ Whether the tile is focusable data TileConfig t = TileConfig
190+ }
191+
192+instance Reflex t => Default (TileConfig t) where
193+ def = TileConfig (pure $ Constraint_Min 0) (pure True)
194+
195+-- | A 'tile' of a fixed size that is focusable and gains focus on click
196+fixed
197+ :: (Reflex t, Monad m, MonadNodeId m)
198+ => Dynamic t Int
199+ -> VtyWidget t m a
200+ -> Layout t m a
201+fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
202+
203+-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
204+-- This tile is focusable and gains focus on click.
205+stretch
206+ :: (Reflex t, Monad m, MonadNodeId m)
207+ => VtyWidget t m a
208+ -> Layout t m a
209+stretch = tile def . clickable
210+
211+-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
212+-- change tile focus.
213+col
214+ :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
215+ => Layout t m a
216+ -> VtyWidget t m a
217+col child = do
218+ nav <- tabNavigation
219+ runLayout (pure Orientation_Column) 0 nav child
220+
221+-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
222+-- change tile focus.
223+row
224+ :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
225+ => Layout t m a
226+ -> VtyWidget t m a
227+row child = do
228+ nav <- tabNavigation
229+ runLayout (pure Orientation_Column) 0 nav child
230+
231+-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
232+-- and backward one tile when Shift+Tab is pressed.
233+tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
234+tabNavigation = do
235+ fwd <- fmap (const 1) <$> key (V.KChar '\t')
236+ back <- fmap (const (-1)) <$> key V.KBackTab
237+ return $ leftmost [fwd, back]
238+
239+-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
240+-- requesting focus when using 'tile'.
241+clickable
242+ :: (Reflex t, Monad m)
243+ => VtyWidget t m a
244+ -> VtyWidget t m (Event t (), a)
245+clickable child = do
246+ click <- mouseDown V.BLeft
247+ a <- child
248+ return (() <$ click, a)
249+
250+-- | Retrieve the current orientation of a 'Layout'
251+askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
252+askOrientation = Layout $ asks _layoutCtx_orientation
253+
254+-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
255+data Constraint = Constraint_Fixed Int
256+ | Constraint_Min Int
257+ deriving (Show, Read, Eq, Ord)
258+
259+-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
260+computeSizes
261+ :: Ord k
262+ => Int
263+ -> Map k (a, Constraint)
264+ -> Map k (a, Int)
265+computeSizes available constraints =
266+ let minTotal = sum $ ffor (Map.elems constraints) $ \case
267+ (_, Constraint_Fixed n) -> n
268+ (_, Constraint_Min n) -> n
269+ leftover = max 0 (available - minTotal)
270+ numStretch = Map.size $ Map.filter (isMin . snd) constraints
271+ szStretch = floor $ leftover % (max numStretch 1)
272+ adjustment = max 0 $ available - minTotal - szStretch * numStretch
273+ in snd $ Map.mapAccum (\adj (a, c) -> case c of
274+ Constraint_Fixed n -> (adj, (a, n))
275+ Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
276+ where
277+ isMin (Constraint_Min _) = True
278+ isMin _ = False
279+
280+computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
281+computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
282+ (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
283+
284+