@@ -24,6 +24,12 @@ import Reflex.Vty.Widget
2424
2525-- * Focus
2626
27+-- | Identifies an element that is focusable. Can be created using 'makeFocus'.
28+newtype FocusId = FocusId NodeId
29+ deriving (Eq, Ord)
30+
31+-- | An ordered set of focus identifiers. The order here determines the order
32+-- in which focus cycles between focusable elements.
2733newtype FocusSet = FocusSet { unFocusSet :: OSet FocusId }
2834
2935instance Semigroup FocusSet where
@@ -32,22 +38,28 @@ instance Semigroup FocusSet where
3238instance Monoid FocusSet where
3339 mempty = FocusSet OSet.empty
3440
41+-- | Produces a 'FocusSet' with a single element
3542singletonFS :: FocusId -> FocusSet
3643singletonFS = FocusSet . OSet.singleton
3744
45+-- | Given a 'FocusSet', a currently focused element, and a number of positions
46+-- to move by, determine the newly focused element.
3847shiftFS :: FocusSet -> Maybe FocusId -> Int -> Maybe FocusId
3948shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
4049 Nothing -> OSet.elemAt s 0
4150 Just Nothing -> OSet.elemAt s 0
4251 Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
4352
44−data Refocus = Refocus_Shift Int
45− | Refocus_Id FocusId
46− | Refocus_Clear
53+-- | Operations that change the currently focused element.
54+data Refocus = Refocus_Shift Int -- ^ Shift the focus by a certain number of positions (see 'shiftFS')
55+ | Refocus_Id FocusId -- ^ Focus a particular element
56+ | Refocus_Clear -- ^ Remove focus from all elements
4757
58+-- | A monad transformer that keeps track of the set of focusable elements and
59+-- which, if any, are currently focused, and allows focus requests.
4860newtype Focus t m a = Focus
4961 { unFocus :: DynamicWriterT t FocusSet
50− (ReaderT (Dynamic t (Maybe FocusId)) -- TODO Demux?
62+ (ReaderT (Dynamic t (Maybe FocusId))
5163 (EventWriterT t (First Refocus) m)) a
5264 }
5365 deriving
@@ -70,6 +82,7 @@ instance MonadTrans (Focus t) where
7082 lift = Focus . lift . lift . lift
7183
7284instance (HasVtyInput t m, Monad m) => HasVtyInput t (Focus t m)
85+
7386instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
7487 localCtx f g (Focus w) = Focus $ do
7588 d <- ask
@@ -79,20 +92,24 @@ instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus
7992 return a
8093
8194instance ImageWriter t m => ImageWriter t (Focus t m)
82−instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)
8395
84−newtype FocusId = FocusId NodeId
85− deriving (Eq, Ord)
96+instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)
8697
98+-- | A class for things that can produce focusable elements.
8799class (Monad m, Reflex t) => MonadFocus t m | m -> t where
88− focusId :: m FocusId
100+ -- | Create a focusable element.
101+ makeFocus :: m FocusId
102+ -- | Emit an 'Event' of requests to change the focus.
89103 requestFocus :: Event t Refocus -> m ()
104+ -- | Produce a 'Dynamic' that indicates whether the given 'FocusId' is focused.
90105 isFocused :: FocusId -> m (Dynamic t Bool)
106+ -- | Run an action, additionally returning the focusable elements it produced.
91107 subFoci :: m a -> m (a, Dynamic t FocusSet)
108+ -- | Get a 'Dynamic' of the currently focused element identifier.
92109 focusedId :: m (Dynamic t (Maybe FocusId))
93110
94111instance (Reflex t, MonadFix m, MonadNodeId m) => MonadFocus t (Focus t m) where
95− focusId = do
112+ makeFocus = do
96113 fid <- FocusId <$> lift getNextNodeId
97114 Focus $ tellDyn $ pure $ singletonFS fid
98115 pure fid
@@ -106,6 +123,7 @@ instance (Reflex t, MonadFix m, MonadNodeId m) => MonadFocus t (Focus t m) where
106123 return (a, fs)
107124 focusedId = Focus ask
108125
126+-- | Runs a 'Focus' action, maintaining the selection state internally.
109127runFocus
110128 :: (MonadFix m, MonadHold t m, Reflex t)
111129 => Focus t m a
@@ -121,14 +139,17 @@ runFocus (Focus x) = do
121139 Refocus_Id fid -> Just fid
122140 Refocus_Shift n -> shiftFS fs mf n
123141
124−tile
142+-- | A widget that is focusable and occupies a layout region based on the
143+-- provided constraint. Returns the 'FocusId' allowing for manual focus
144+-- management.
145+tile'
125146 :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
126147 => Dynamic t Constraint
127148 -> m a
128149 -> m (FocusId, a)
129−tile c w = do
130− fid <- focusId
131− r <- leaf c
150+tile' c w = do
151+ fid <- makeFocus
152+ r <- region c
132153 fid' <- focusedId
133154 parentFocused <- isFocused fid
134155 rec (click, result, subs) <- pane r focused $ do
@@ -142,45 +163,70 @@ tile c w = do
142163 requestFocus $ Refocus_Id fid <$ click
143164 pure (fid, result)
144165
145−tile_
166+-- | A widget that is focusable and occupies a layout region based on the
167+-- provided constraint.
168+tile
146169 :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
147170 => Dynamic t Constraint
148171 -> m a
149172 -> m a
150−tile_ c = fmap snd . tile c
173+tile c = fmap snd . tile' c
174+
175+-- | A widget that is not focusable and occupies a layout region based on the
176+-- provided constraint.
177+unfocusable
178+ :: (Reflex t, MonadNodeId m, HasVtyWidgetCtx t m, MonadLayout t m)
179+ => Dynamic t Constraint
180+ -> m a
181+ -> m a
182+unfocusable c w = do
183+ r <- region c
184+ pane r (pure False) w
151185
152186-- * Layout
153187
154−data LTree a = LTree a (LForest a)
188+-- | A collection of information related to the layout of the screen. The root
189+-- node is a "parent" widget, and the contents of the 'LayoutForest' are its
190+-- children.
191+data LayoutTree a = LayoutTree a (LayoutForest a)
155192 deriving (Show)
156193
157−newtype LForest a = LForest { unLForest :: OMap NodeId (LTree a) }
194+-- | An ordered, indexed collection of 'LayoutTree's representing information
195+-- about the children of some widget.
196+newtype LayoutForest a = LayoutForest { unLayoutForest :: OMap NodeId (LayoutTree a) }
158197 deriving (Show)
159198
160−instance Semigroup (LForest a) where
161− LForest a <> LForest b = LForest $ a OMap.|<> b
199+instance Semigroup (LayoutForest a) where
200+ LayoutForest a <> LayoutForest b = LayoutForest $ a OMap.|<> b
162201
163−instance Monoid (LForest a) where
164− mempty = LForest OMap.empty
202+instance Monoid (LayoutForest a) where
203+ mempty = LayoutForest OMap.empty
165204
166−lookupLF :: NodeId -> LForest a -> Maybe (LTree a)
167−lookupLF n (LForest a) = OMap.lookup n a
205+-- | Perform a lookup by 'NodeId' in a 'LayoutForest'
206+lookupLF :: NodeId -> LayoutForest a -> Maybe (LayoutTree a)
207+lookupLF n (LayoutForest a) = OMap.lookup n a
168208
169−singletonLF :: NodeId -> LTree a -> LForest a
170−singletonLF n t = LForest $ OMap.singleton (n, t)
209+-- | Create a 'LayoutForest' with one element
210+singletonLF :: NodeId -> LayoutTree a -> LayoutForest a
211+singletonLF n t = LayoutForest $ OMap.singleton (n, t)
171212
172−fromListLF :: [(NodeId, LTree a)] -> LForest a
173−fromListLF = LForest . OMap.fromList
213+-- | Produce a 'LayoutForest' from a list. The order of the list is preserved.
214+fromListLF :: [(NodeId, LayoutTree a)] -> LayoutForest a
215+fromListLF = LayoutForest . OMap.fromList
174216
175−ltreeRoot :: LTree a -> a
176−ltreeRoot (LTree a _) = a
217+-- | Extract the information at the root of a 'LayoutTree'
218+rootLT :: LayoutTree a -> a
219+rootLT (LayoutTree a _) = a
177220
178−ltreeForest :: LTree a -> LForest a
179−ltreeForest (LTree _ a) = a
221+-- | Extract the child nodes of a 'LayoutTree'
222+childrenLT :: LayoutTree a -> LayoutForest a
223+childrenLT (LayoutTree _ a) = a
180224
225+-- | A monad transformer that collects layout constraints and provides a layout
226+-- solution that satisfies those constraints.
181227newtype Layout t m a = Layout
182− { unLayout :: DynamicWriterT t (LForest (Constraint, Orientation))
183− (ReaderT (Dynamic t (LTree (Region, Orientation))) m) a
228+ { unLayout :: DynamicWriterT t (LayoutForest (Constraint, Orientation))
229+ (ReaderT (Dynamic t (LayoutTree (Region, Orientation))) m) a
184230 }
185231 deriving
186232 ( Functor
@@ -204,38 +250,46 @@ instance MonadTrans (Layout t) where
204250instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Layout t m) where
205251 localCtx f g x = do
206252 solution <- Layout ask
207− let orientation = snd . ltreeRoot <$> solution
253+ let orientation = snd . rootLT <$> solution
208254 lift $ localCtx f g $ do
209255 dw <- displayWidth
210256 dh <- displayHeight
211− let region = Region 0 0 <$> dw <*> dh
212− runLayout orientation region x
257+ let reg = Region 0 0 <$> dw <*> dh
258+ runLayout orientation reg x
213259
214260instance (HasVtyInput t m, Monad m) => HasVtyInput t (Layout t m)
261+
215262instance ImageWriter t m => ImageWriter t (Layout t m)
263+
216264instance (HasFocus t m, Monad m) => HasFocus t (Layout t m)
217265
218−-- TODO Naming: To Has or not to Has?
266+-- | A class of operations for creating screen layouts.
219267class Monad m => MonadLayout t m | m -> t where
268+ -- | Creates a parent element in the current layout with the given size
269+ -- constraint, which lays out its children according to the provided
270+ -- orientation.
220271 axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
221− leaf :: Dynamic t Constraint -> m (Dynamic t Region)
272+ -- | Creates a child element in the current layout with the given size
273+ -- constraint, returning the 'Region' that the child element is allocated.
274+ region :: Dynamic t Constraint -> m (Dynamic t Region)
275+ -- | Returns the orientation of the containing 'axis'.
222276 askOrientation :: m (Dynamic t Orientation)
223277
224278instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => MonadLayout t (Layout t m) where
225279 axis o c (Layout x) = Layout $ do
226280 nodeId <- getNextNodeId
227− (result, forest) <- lift $ local (\t -> (\(Just a) -> a) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x
228− tellDyn $ singletonLF nodeId <$> (LTree <$> ((,) <$> c <*> o) <*> forest)
281+ (result, forest) <- lift $ local (\t -> (\(Just a) -> a) . lookupLF nodeId . childrenLT <$> t) $ runDynamicWriterT x
282+ tellDyn $ singletonLF nodeId <$> (LayoutTree <$> ((,) <$> c <*> o) <*> forest)
229283 pure result
230− leaf c = do
284+ region c = do
231285 nodeId <- lift getNextNodeId
232− Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
286+ Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LayoutTree (c', Orientation_Row) mempty
233287 solutions <- Layout ask
234− pure $ maybe (error "leaf: could not find layout solution") (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions
235− askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
288+ pure $ maybe (error "region: could not find layout solution") (fst . rootLT) . lookupLF nodeId . childrenLT <$> solutions
289+ askOrientation = Layout $ asks $ fmap (snd . rootLT)
236290
237291instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where
238− focusId = lift focusId
292+ makeFocus = lift makeFocus
239293 requestFocus = lift . requestFocus
240294 isFocused = lift . isFocused
241295 focusedId = lift focusedId
@@ -255,74 +309,113 @@ data Orientation = Orientation_Column
255309 | Orientation_Row
256310 deriving (Show, Read, Eq, Ord)
257311
258−
259−row, col
312+-- | Create a row-oriented 'axis'
313+row
260314 :: (Reflex t, MonadNodeId m, MonadFix m, MonadLayout t m)
261315 => m a
262316 -> m a
263317row = axis (pure Orientation_Row) (pure $ Constraint_Min 0)
318+
319+-- | Create a column-oriented 'axis'
320+col
321+ :: (Reflex t, MonadNodeId m, MonadFix m, MonadLayout t m)
322+ => m a
323+ -> m a
264324col = axis (pure Orientation_Column) (pure $ Constraint_Min 0)
265325
266−fixed
326+-- | A tile constrained to the given size. Returns the 'FocusId' of the tile,
327+-- allowing for manual focus management.
328+fixed'
267329 :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
268330 => Dynamic t Int
269331 -> m a
270332 -> m (FocusId, a)
271−fixed n = tile (Constraint_Fixed <$> n)
333+fixed' n = tile' (Constraint_Fixed <$> n)
272334
273−fixed_
335+-- | A tile constrained to the given size.
336+fixed
274337 :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
275338 => Dynamic t Int
276339 -> m a
277340 -> m a
278−fixed_ n = fmap snd . fixed n
341+fixed n = fmap snd . fixed' n
279342
280−stretch
343+-- | A tile that can grow, but will always occupy at least the given minimum
344+-- size. Returns the 'FocusId' of the tile, allowing for manual focus
345+-- management.
346+stretch'
281347 :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
282348 => Dynamic t Int
283349 -> m a
284350 -> m (FocusId, a)
285−stretch minSz = tile (Constraint_Min <$> minSz)
351+stretch' minSz = tile' (Constraint_Min <$> minSz)
286352
287−stretch_
353+-- | A tile that can grow, but will always occupy at least the given minimum
354+-- size.
355+stretch
288356 :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
289357 => Dynamic t Int
290358 -> m a
291359 -> m a
292−stretch_ minSz = fmap snd . tile (Constraint_Min <$> minSz)
360+stretch minSz = fmap snd . stretch' minSz
293361
294−flex
362+-- | A tile that can grow or shrink without constraint. Returns the 'FocusId'
363+-- of the tile, allowing for manual focus management.
364+flex'
295365 :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
296366 => m a
297367 -> m (FocusId, a)
298−flex = tile (pure $ Constraint_Min 0)
368+flex' = tile' (pure $ Constraint_Min 0)
299369
300−flex_
370+-- | A tile that can grow or shrink without constraint.
371+flex
301372 :: (Reflex t,MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
302373 => m a
303374 -> m a
304−flex_ = fmap snd . flex
305−
306−ltreeConstraint :: LTree (Constraint, a) -> Constraint
307−ltreeConstraint (LTree (c, _) _) = c
375+flex = fmap snd . flex'
308376
377+-- | Produce a layout solution given a starting orientation, the overall screen
378+-- size, and a set of constraints.
309379solve
310380 :: Orientation
311381 -> Region
312− -> LForest (Constraint, Orientation)
313− -> LTree (Region, Orientation)
314−solve o0 r0 (LForest cs) =
315− let a = map (\(x, t) -> ((x, t), ltreeConstraint t)) $ OMap.assocs cs
382+ -> LayoutForest (Constraint, Orientation)
383+ -> LayoutTree (Region, Orientation)
384+solve o0 r0 (LayoutForest cs) =
385+ let a = map (\(x, t@(LayoutTree (c, _) _)) -> ((x, t), c)) $ OMap.assocs cs
316386 extent = case o0 of
317387 Orientation_Row -> _region_width r0
318388 Orientation_Column -> _region_height r0
319389 sizes = computeEdges $ computeSizes extent a
320390 chunks = [ (nodeId, solve o1 r1 f)
321− | ((nodeId, LTree (_, o1) f), sz) <- sizes
391+ | ((nodeId, LayoutTree (_, o1) f), sz) <- sizes
322392 , let r1 = chunk o0 r0 sz
323393 ]
324− in LTree (r0, o0) $ fromListLF chunks
394+ in LayoutTree (r0, o0) $ fromListLF chunks
395+ where
396+ computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
397+ computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
398+ (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
399+ computeSizes
400+ :: Int
401+ -> [(a, Constraint)]
402+ -> [(a, Int)]
403+ computeSizes available constraints =
404+ let minTotal = sum $ ffor constraints $ \case
405+ (_, Constraint_Fixed n) -> n
406+ (_, Constraint_Min n) -> n
407+ leftover = max 0 (available - minTotal)
408+ numStretch = length $ filter (isMin . snd) constraints
409+ szStretch = floor $ leftover % max numStretch 1
410+ adjustment = max 0 $ available - minTotal - szStretch * numStretch
411+ in snd $ mapAccumL (\adj (a, c) -> case c of
412+ Constraint_Fixed n -> (adj, (a, n))
413+ Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
414+ isMin (Constraint_Min _) = True
415+ isMin _ = False
325416
417+-- | Produce a 'Region' given a starting orientation and region, and the offset
418+-- and main-axis size of the chunk.
326419chunk :: Orientation -> Region -> (Int, Int) -> Region
327420chunk o r (offset, sz) = case o of
328421 Orientation_Column -> r
@@ -334,30 +427,8 @@ chunk o r (offset, sz) = case o of
334427 , _region_width = sz
335428 }
336429
337−-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
338−computeSizes
339− :: Int
340− -> [(a, Constraint)]
341− -> [(a, Int)]
342−computeSizes available constraints =
343− let minTotal = sum $ ffor constraints $ \case
344− (_, Constraint_Fixed n) -> n
345− (_, Constraint_Min n) -> n
346− leftover = max 0 (available - minTotal)
347− numStretch = length $ filter (isMin . snd) constraints
348− szStretch = floor $ leftover % max numStretch 1
349− adjustment = max 0 $ available - minTotal - szStretch * numStretch
350− in snd $ mapAccumL (\adj (a, c) -> case c of
351− Constraint_Fixed n -> (adj, (a, n))
352− Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
353− where
354− isMin (Constraint_Min _) = True
355− isMin _ = False
356−
357−computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
358−computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
359− (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
360−
430+-- | Runs a 'Layout' action, using the given orientation and region to
431+-- calculate layout solutions.
361432runLayout
362433 :: (MonadFix m, Reflex t)
363434 => Dynamic t Orientation
@@ -369,6 +440,8 @@ runLayout o r (Layout x) = do
369440 let solutions = solve <$> o <*> r <*> w
370441 return result
371442
443+-- | Request focus be shifted backward and forward based on tab presses. <Tab>
444+-- shifts focus forward and <Shift+Tab> shifts focus backward.
372445tabNavigation :: (Reflex t, MonadNodeId m, HasVtyInput t m, MonadFocus t m) => m ()
373446tabNavigation = do
374447 fwd <- fmap (const 1) <$> key (V.KChar '\t')
@@ -387,25 +460,25 @@ test = mainWidget $ do
387460 initManager_ $ do
388461 tabNavigation
389462 col $ do
390− fixed_ 5 $ box' $ row $ do
391− flex_ $ do
463+ fixed 5 $ box' $ row $ do
464+ flex $ do
392465 text' "asdf"
393− flex_ $ text' "xyz"
394− fixed_ 5 $ do
466+ flex $ text' "xyz"
467+ fixed 5 $ do
395468 text' " 1"
396469 row $ do
397− tile_ (pure $ Constraint_Min 0) $ do
470+ flex $ do
398471 text' "2"
399− flex_ $ text' "3"
400− flex_ $ text' "xyz"
401− flex_ $ text' "xyz"
402− flex_ $ text' "asdf"
403− flex_ $ text' "asdf"
472+ flex $ text' "3"
473+ flex $ text' "xyz"
474+ flex $ text' "xyz"
475+ flex $ text' "asdf"
476+ flex $ text' "asdf"
404477 return $ fforMaybe inp $ \case
405478 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
406479 _ -> Nothing
407480
408−-- TODO: 'Manager'? as in "window manager"
481+-- | Initialize a 'Layout' and 'Focus' management context, returning the produced 'FocusSet'.
409482initManager
410483 :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
411484 => Layout t (Focus t m) a
@@ -416,6 +489,7 @@ initManager f = do
416489 let r = Region 0 0 <$> dw <*> dh
417490 runFocus $ runLayout (pure Orientation_Column) r f
418491
492+-- | Initialize a 'Layout' and 'Focus' management context.
419493initManager_
420494 :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
421495 => Layout t (Focus t m) a