@@ -7,45 +7,300 @@ Description: Monad transformer and tools for arranging widgets and building scre
77{-# LANGUAGE LambdaCase #-}
88{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE RecursiveDo #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE OverloadedStrings #-}
12+{-# LANGUAGE TupleSections #-}
1013{-# LANGUAGE UndecidableInstances #-}
1114
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(..))
15+module Reflex.Vty.Widget.Layout where
16+ -- ( Orientation(..)
17+ -- , Constraint(..)
18+ -- , Layout
19+ -- , runLayout
20+ -- , TileConfig(..)
21+ -- , tile
22+ -- , fixed
23+ -- , stretch
24+ -- , col
25+ -- , row
26+ -- , tabNavigation
27+ -- , askOrientation
28+ -- ) where
29+
30+import Control.Monad.NodeId (MonadNodeId(..), NodeId, NodeIdT)
2831import Control.Monad.Reader
2932import Data.Bimap (Bimap)
3033import qualified Data.Bimap as Bimap
3134import Data.Default (Default(..))
35+import Data.List
3236import Data.Map (Map)
3337import qualified Data.Map as Map
3438import Data.Maybe (fromMaybe)
3539import Data.Monoid hiding (First(..))
3640import Data.Ratio ((%))
3741import Data.Semigroup (First(..))
42+import Data.Sequence (Seq)
43+import qualified Data.Sequence as Seq
3844import qualified Graphics.Vty as V
45+import Data.Map.Ordered (OMap, Bias(..), L)
46+import qualified Data.Map.Ordered as OMap
47+import qualified Graphics.Vty.Attributes as V
3948
4049import Reflex
4150import Reflex.Host.Class (MonadReflexCreateTrigger)
4251import Reflex.Vty.Widget
4352
53+-- * Focus
54+
55+newtype Focus t m a = Focus
56+ { unFocus :: DynamicWriterT t (Seq FocusId) (ReaderT (Demux t (Maybe FocusId)) m) a
57+ }
58+ deriving
59+ ( Functor
60+ , Applicative
61+ , Monad
62+ , MonadHold t
63+ , MonadSample t
64+ , MonadFix
65+ , TriggerEvent t
66+ , PerformEvent t
67+ , NotReady t
68+ , MonadReflexCreateTrigger t
69+ , HasDisplaySize t
70+ , PostBuild t
71+ , MonadNodeId
72+ )
73+
74+instance MonadTrans (Focus t) where
75+ lift = Focus . lift . lift
76+
77+newtype FocusId = FocusId NodeId
78+ deriving (Eq, Ord)
79+
80+focusId :: (MonadNodeId m, Reflex t) => Focus t m FocusId
81+focusId = do
82+ fid <- FocusId <$> lift getNextNodeId
83+ Focus $ tellDyn $ pure $ Seq.singleton fid
84+ pure fid
85+
86+runFocus
87+ :: (MonadFix m, MonadHold t m, Reflex t)
88+ => Event t (Maybe FocusId)
89+ -> Focus t m a
90+ -> m (a, Dynamic t (Seq FocusId))
91+runFocus e (Focus x) = do
92+ rec (a, focusIds) <- flip runReaderT (demux sel) $ runDynamicWriterT x
93+ sel <- holdDyn Nothing e
94+ pure (a, focusIds)
95+
96+withFocus
97+ :: (Reflex t, Monad m)
98+ => FocusId
99+ -> (Dynamic t Bool -> Focus t m a) -- TODO unnecessary: just return the dynamic bool
100+ -> Focus t m a
101+withFocus focusId builder = do
102+ sel <- Focus ask
103+ builder $ demuxed sel $ Just focusId
104+
105+-- focus builder = do
106+-- fid <- focusId
107+-- withFocus fid builder
108+
109+-- | Configuration options for and constraints on 'tile'
110+data TileConfig t = TileConfig
111+ { _tileConfig_constraint :: Dynamic t Constraint
112+ -- ^ 'Constraint' on the tile's size
113+ , _tileConfig_focusable :: Dynamic t Bool
114+ -- ^ Whether the tile is focusable
115+ }
116+
117+instance Reflex t => Default (TileConfig t) where
118+ def = TileConfig (pure $ Constraint_Min 0) (pure True)
119+
120+tile
121+ :: (MonadNodeId m, MonadFix m, Reflex t)
122+ => VtyWidget t m a
123+ -> Layout t (Focus t (VtyWidget t m)) a
124+tile w = do
125+ fid <- lift focusId
126+ focused <- lift $ withFocus fid return
127+ stretch $ \r -> lift $ pane r focused w
128+
129+-- * Layout
130+
131+data LTree a = LTree a (LForest a)
132+
133+newtype LForest a = LForest { unLForest :: OMap NodeId (LTree a) }
134+
135+instance Semigroup (LForest a) where
136+ LForest a <> LForest b = LForest $ a OMap.|<> b
137+
138+instance Monoid (LForest a) where
139+ mempty = LForest OMap.empty
140+
141+lookupLF :: NodeId -> LForest a -> Maybe (LTree a)
142+lookupLF n (LForest a) = OMap.lookup n a
143+
144+singletonLF :: NodeId -> LTree a -> LForest a
145+singletonLF n t = LForest $ OMap.singleton (n, t)
146+
147+fromListLF :: [(NodeId, LTree a)] -> LForest a
148+fromListLF = LForest . OMap.fromList
149+
150+ltreeRoot :: LTree a -> a
151+ltreeRoot (LTree a _) = a
152+
153+ltreeForest :: LTree a -> LForest a
154+ltreeForest (LTree _ a) = a
155+
156+newtype Layout t m a = Layout
157+ { unLayout :: DynamicWriterT t (LForest (Constraint, Orientation))
158+ (ReaderT (Dynamic t (LTree (Region, Orientation))) m) a
159+ }
160+ deriving
161+ ( Functor
162+ , Applicative
163+ , Monad
164+ , MonadHold t
165+ , MonadSample t
166+ , MonadFix
167+ , TriggerEvent t
168+ , PerformEvent t
169+ , NotReady t
170+ , MonadReflexCreateTrigger t
171+ , HasDisplaySize t
172+ , PostBuild t
173+ , MonadNodeId
174+ )
175+
176+instance MonadTrans (Layout t) where
177+ lift = Layout . lift . lift
178+
179+-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
180+data Constraint = Constraint_Fixed Int
181+ | Constraint_Min Int
182+ deriving (Show, Read, Eq, Ord)
183+
44184-- | The main-axis orientation of a 'Layout' widget
45185data Orientation = Orientation_Column
46186 | Orientation_Row
47187 deriving (Show, Read, Eq, Ord)
48188
189+axis
190+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
191+ => Orientation
192+ -> Constraint
193+ -> Layout t m a
194+ -> Layout t m a
195+axis o c (Layout x) = Layout $ do
196+ nodeId <- getNextNodeId
197+ (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x -- TODO?
198+ tellDyn $ fmap (singletonLF nodeId . LTree (c, o)) forest
199+ pure result
200+
201+row, col
202+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
203+ => Constraint
204+ -> Layout t m a
205+ -> Layout t m a
206+row = axis Orientation_Row
207+col = axis Orientation_Column
208+
209+leaf
210+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
211+ => Dynamic t Constraint
212+ -> (DynRegion t -> m a)
213+ -> Layout t m a
214+leaf c f = do
215+ nodeId <- lift getNextNodeId
216+ Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
217+ solutions <- Layout ask
218+ let r = maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions -- TODO revisit this fromMaybe
219+ lift $ f $ dynRegion r
220+
221+fixed
222+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
223+ => Dynamic t Int
224+ -> (DynRegion t -> m a)
225+ -> Layout t m a
226+fixed = leaf . fmap Constraint_Fixed
227+
228+stretch
229+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
230+ => (DynRegion t -> m a)
231+ -> Layout t m a
232+stretch = leaf (pure $ Constraint_Min 0)
233+
234+askOrientation :: (Monad m, Reflex t) => Layout t m (Dynamic t Orientation)
235+askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
236+
237+ltreeConstraint :: LTree (Constraint, a) -> Constraint
238+ltreeConstraint (LTree (c, _) _) = c
239+
240+solve
241+ :: Orientation
242+ -> Region
243+ -> LForest (Constraint, Orientation)
244+ -> LTree (Region, Orientation)
245+solve o0 r0 (LForest cs) =
246+ let a = map (\(x, t) -> ((x, t), ltreeConstraint t)) $ OMap.assocs cs
247+ extent = case o0 of
248+ Orientation_Row -> _region_width r0
249+ Orientation_Column -> _region_height r0
250+ sizes = computeEdges $ computeSizes extent a
251+ chunks = [ (nodeId, solve o1 r1 f)
252+ | ((nodeId, LTree (_, o1) f), sz) <- sizes
253+ , let r1 = chunk o0 r0 sz
254+ ]
255+ in LTree (r0, o0) $ fromListLF chunks
256+
257+chunk :: Orientation -> Region -> (Int, Int) -> Region
258+chunk o r (offset, sz) = case o of
259+ Orientation_Column -> r
260+ { _region_top = _region_top r + offset
261+ , _region_height = sz
262+ }
263+ Orientation_Row -> r
264+ { _region_left = _region_left r + offset
265+ , _region_width = sz
266+ }
267+
268+-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
269+computeSizes
270+ :: Int
271+ -> [(a, Constraint)]
272+ -> [(a, Int)]
273+computeSizes available constraints =
274+ let minTotal = sum $ ffor constraints $ \case
275+ (_, Constraint_Fixed n) -> n
276+ (_, Constraint_Min n) -> n
277+ leftover = max 0 (available - minTotal)
278+ numStretch = length $ filter (isMin . snd) constraints
279+ szStretch = floor $ leftover % (max numStretch 1)
280+ adjustment = max 0 $ available - minTotal - szStretch * numStretch
281+ in snd $ mapAccumL (\adj (a, c) -> case c of
282+ Constraint_Fixed n -> (adj, (a, n))
283+ Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
284+ where
285+ isMin (Constraint_Min _) = True
286+ isMin _ = False
287+
288+computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
289+computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
290+ (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
291+
292+runLayout
293+ :: (MonadFix m, Reflex t)
294+ => Dynamic t Orientation
295+ -> Dynamic t Region
296+ -> Layout t m a
297+ -> m a
298+runLayout o r (Layout x) = do
299+ rec (result, w) <- runReaderT (runDynamicWriterT x) solutions
300+ let solutions = solve <$> o <*> r <*> w
301+ return result
302+
303+{-
49304data LayoutSegment = LayoutSegment
50305 { _layoutSegment_offset :: Int
51306 , _layoutSegment_size :: Int
@@ -119,23 +374,23 @@ runLayout ddir focus0 focusShift (Layout child) = do
119374 { _layoutSegment_offset = offset
120375 , _layoutSegment_size = sz
121376 }
122− focusable = fmap (Bimap.fromList . zip [0..]) $
123− ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
124− if f then Just nodeId else Nothing
125− adjustFocus
126− :: (Bimap Int NodeId, (Int, Maybe NodeId))
127− -> Either Int NodeId
128− -> (Int, Maybe NodeId)
129− adjustFocus (fm, (cur, _)) (Left shift) =
130− let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
131− in (ix, Bimap.lookup ix fm)
132− adjustFocus (fm, (cur, _)) (Right goto) =
133− let ix = fromMaybe cur $ Bimap.lookupR goto fm
134− in (ix, Just goto)
135− focusChange = attachWith
136− adjustFocus
137− (current $ (,) <$> focusable <*> focussed)
138− $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
377+ -- focusable = fmap (Bimap.fromList . zip [0..]) $
378+ -- ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
379+ -- if f then Just nodeId else Nothing
380+ -- adjustFocus
381+ -- :: (Bimap Int NodeId, (Int, Maybe NodeId))
382+ -- -> Either Int NodeId
383+ -- -> (Int, Maybe NodeId)
384+ -- adjustFocus (fm, (cur, _)) (Left shift) =
385+ -- let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
386+ -- in (ix, Bimap.lookup ix fm)
387+ -- adjustFocus (fm, (cur, _)) (Right goto) =
388+ -- let ix = fromMaybe cur $ Bimap.lookupR goto fm
389+ -- in (ix, Just goto)
390+ -- focusChange = attachWith
391+ -- adjustFocus
392+ -- (current $ (,) <$> focusable <*> focussed)
393+ -- $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
139394 -- A pair (Int, Maybe NodeId) which represents the index
140395 -- that we're trying to focus, and the node that actually gets
141396 -- focused (at that index) if it exists
@@ -252,34 +507,41 @@ clickable child = do
252507askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
253508askOrientation = Layout $ asks _layoutCtx_orientation
254509
255−-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
256−data Constraint = Constraint_Fixed Int
257− | Constraint_Min Int
258− deriving (Show, Read, Eq, Ord)
259−
260−-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
261−computeSizes
262− :: Ord k
263− => Int
264− -> Map k (a, Constraint)
265− -> Map k (a, Int)
266−computeSizes available constraints =
267− let minTotal = sum $ ffor (Map.elems constraints) $ \case
268− (_, Constraint_Fixed n) -> n
269− (_, Constraint_Min n) -> n
270− leftover = max 0 (available - minTotal)
271− numStretch = Map.size $ Map.filter (isMin . snd) constraints
272− szStretch = floor $ leftover % (max numStretch 1)
273− adjustment = max 0 $ available - minTotal - szStretch * numStretch
274− in snd $ Map.mapAccum (\adj (a, c) -> case c of
275− Constraint_Fixed n -> (adj, (a, n))
276− Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
277− where
278− isMin (Constraint_Min _) = True
279− isMin _ = False
510+-}
280511
281−computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
282−computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
283− (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
512+-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
513+-- and backward one tile when Shift+Tab is pressed.
514+tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
515+tabNavigation = do
516+ fwd <- fmap (const 1) <$> key (V.KChar '\t')
517+ back <- fmap (const (-1)) <$> key V.KBackTab
518+ return $ leftmost [fwd, back]
284519
520+test :: IO ()
521+test = mainWidget $ do
522+ inp <- input
523+ dw <- displayWidth
524+ dh <- displayHeight
525+ let r = Region <$> 0 <*> 0 <*> dw <*> dh
526+ text' t = do
527+ f <- focus
528+ richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.bold else V.defAttr) <$> f) t
529+ tab <- tabNavigation
530+ rec (_, focusSeq) <- runFocus (updated sel) $ runLayout (pure Orientation_Column) r $ do -- TODO start focused
531+ col (Constraint_Min 0) $ do
532+ tile $ text' "asdf"
533+ tile $ text' "asdf"
534+ row (Constraint_Min 0) $ do
535+ tile $ text' "xyz"
536+ tile $ text' "xyz"
537+ tile $ text' "xyz"
538+ tile $ text' "xyz"
539+ tile $ text' "asdf"
540+ tile $ text' "asdf"
541+ ix <- foldDyn (+) 0 tab
542+ let sel = Seq.lookup <$> (mod <$> ix <*> (Seq.length <$> focusSeq)) <*> focusSeq -- TODO this sucks: when elements are added your focus will shift (OSet)
543+ return $ fforMaybe inp $ \case
544+ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
545+ _ -> Nothing
285546
547+ -- TODO These functions shouldn't be so higher order