diff --git a/src-bin/example.hs b/src-bin/example.hs index 6b21a5c..7863639 100644 --- a/src-bin/example.hs +++ b/src-bin/example.hs @@ -7,12 +7,16 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + + {-# OPTIONS_GHC -threaded #-} import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.NodeId +import Data.Functor import Data.Functor.Misc import Data.Map (Map) import Data.Maybe @@ -26,6 +30,36 @@ import Reflex.Network import Reflex.Class.Switchable import Reflex.Vty +easyExample :: IO () +easyExample = mainWidget $ do + beginLayout $ row $ fixedL 39 $ col $ do + (a1,b1,c1) <- fixedL 3 $ row $ do + a <- stretch $ textButtonStatic def "POTATO" + b <- stretch $ textButtonStatic def "TOMATO" + c <- stretch $ textButtonStatic def "EGGPLANT" + return (a,b,c) + (a2,b2,c2) <- fixedL 3 $ row $ do + a <- stretch $ textButtonStatic def "CHEESE" + b <- stretch $ textButtonStatic def "BEES" + c <- stretch $ textButtonStatic def "MY KNEES" + return (a,b,c) + (a3,b3,c3) <- fixedL 3 $ row $ do + a <- stretch $ textButtonStatic def "TIME" + b <- stretch $ textButtonStatic def "RHYME" + c <- stretch $ textButtonStatic def "A BIG CRIME" + return (a,b,c) + -- NOTE the box will most likely not render correctly once you put emoji's + -- you need to initialize vty with an updated char width map to fix this + fixed 7 $ boxTitle (constant def) "CLICK BUTTONS TO DRAW" $ do + outputDyn <- foldDyn (<>) "" $ mergeWith (<>) + [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"] + text (current outputDyn) + inp <- input + return $ fforMaybe inp $ \case + V.EvKey (V.KChar 'c') [V.MCtrl] -> Just () + _ -> Nothing + + data Example = Example_TextEditor | Example_Todo | Example_ScrollableTextDisplay @@ -34,8 +68,8 @@ data Example = Example_TextEditor main :: IO () main = mainWidget $ do inp <- input - let buttons = col $ do - fixed 4 $ col $ do + let buttons = beginLayout $ col $ do + fixedL 4 $ col $ do fixed 1 $ text "Select an example." fixed 1 $ text "Esc will bring you back here." fixed 1 $ text "Ctrl+c to quit." @@ -61,7 +95,7 @@ main = mainWidget $ do return $ fforMaybe inp $ \case V.EvKey (V.KChar 'c') [V.MCtrl] -> Just () _ -> Nothing - + taskList :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m) => VtyWidget t m () @@ -153,7 +187,7 @@ todo t0 = do checkboxRegion = DynRegion 0 0 checkboxWidth 1 labelHeight = _textInput_lines ti labelWidth = w - 1 - checkboxWidth - labelLeft = checkboxWidth + 1 + labelLeft = checkboxWidth + 1 labelTop = constDyn 0 labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0 @@ -173,7 +207,7 @@ todo t0 = do _ -> Nothing scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m () -scrolling = col $ do +scrolling = beginLayout $ col $ do fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:" out <- fixed 5 $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant." fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total) @@ -195,9 +229,10 @@ todos todos0 newTodo = do let todosMap0 = Map.fromList $ zip [0..] todos0 rec tabNav <- tabNavigation let insertNav = 1 <$ insert - nav = leftmost [tabNav, insertNav] + navEv = leftmost [tabNav, insertNav] + focusEv = layoutFocusEvFromNavigation navEv never lrd tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1} - listOut <- runLayout (pure Orientation_Column) 0 nav $ + lrd@LayoutReturnData {..} <- flip runIsLayoutVtyWidget focusEv $ runLayoutL (pure Orientation_Column) (Just 0) $ listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do let sel = select selectOnDelete $ Const2 k click <- void <$> mouseDown V.BLeft @@ -208,8 +243,8 @@ todos todos0 newTodo = do let delete = ffor todoDelete $ \k -> Map.singleton k Nothing updates = leftmost [insert, delete] todoDelete = switch . current $ - leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut - todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut + leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> _layoutReturnData_value + todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> _layoutReturnData_value insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of Nothing -> Map.singleton 0 $ Just $ Todo "" False Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False @@ -218,4 +253,4 @@ todos todos0 newTodo = do in fmap fst $ Map.lookupMax before <|> Map.lookupMin after) (current todosMap) todoDelete - return listOut + return _layoutReturnData_value diff --git a/src/Reflex/Vty/Widget/Layout.hs b/src/Reflex/Vty/Widget/Layout.hs index 07b54b8..7389b13 100644 --- a/src/Reflex/Vty/Widget/Layout.hs +++ b/src/Reflex/Vty/Widget/Layout.hs @@ -2,44 +2,77 @@ Module: Reflex.Vty.Widget.Layout Description: Monad transformer and tools for arranging widgets and building screen layouts -} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + module Reflex.Vty.Widget.Layout - ( Orientation(..) + ( Orientation(..) , Constraint(..) , Layout + , runLayoutL , runLayout , TileConfig(..) + , clickable + , tile_ , tile , fixed + , fixedL , stretch + , stretchL , col , row + , dummyCell + , beginLayout + , beginLayoutL + , layoutFocusEvFromNavigation , tabNavigation , askOrientation + , LayoutVtyWidget(..) + , LayoutTree + , dynLayoutTreeInDynRegion + , layoutTreeCellToPosition + , IsLayoutVtyWidget(..) + , LayoutReturnData(..) ) where -import Control.Monad.NodeId (NodeId, MonadNodeId(..)) -import Control.Monad.Reader -import Data.Bimap (Bimap) -import qualified Data.Bimap as Bimap -import Data.Default (Default(..)) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Monoid hiding (First(..)) -import Data.Ratio ((%)) -import Data.Semigroup (First(..)) -import qualified Graphics.Vty as V - -import Reflex -import Reflex.Host.Class (MonadReflexCreateTrigger) -import Reflex.Vty.Widget + +import Prelude + +import Control.Monad.Identity (Identity (..)) +import Control.Monad.NodeId (MonadNodeId (..), NodeId) +import Control.Monad.Reader +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Default (Default (..)) +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum (DSum ((:=>))) +import Data.Functor +import Data.Functor.Misc +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Internal as Map (Map (Bin, Tip)) +import Data.Maybe (fromMaybe) +import Data.Monoid hiding (First (..)) +import Data.Ratio ((%)) +import Data.Semigroup (First (..)) +import Data.Traversable (mapAccumL) +import qualified Data.Tree as Tree +import qualified Graphics.Vty as V + +import Reflex +import Reflex.Host.Class (MonadReflexCreateTrigger) +import Reflex.Vty.Widget -- | The main-axis orientation of a 'Layout' widget data Orientation = Orientation_Column @@ -48,21 +81,23 @@ data Orientation = Orientation_Column data LayoutSegment = LayoutSegment { _layoutSegment_offset :: Int - , _layoutSegment_size :: Int + , _layoutSegment_size :: Int } data LayoutCtx t = LayoutCtx - { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment) - , _layoutCtx_focusDemux :: Demux t (Maybe NodeId) - , _layoutCtx_orientation :: Dynamic t Orientation + { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment) + , _layoutCtx_focusSelfDemux :: Demux t (Maybe NodeId) + , _layoutCtx_orientation :: Dynamic t Orientation + , _layoutCtx_focusChildSelector :: EventSelector t (Const2 NodeId (Maybe Int)) } + -- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and -- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a --- switchboard for focus requests. See 'tile' and 'runLayout'. +-- switchboard for focus requests. See 'tile_' and 'runLayout'. newtype Layout t m a = Layout - { unLayout :: EventWriterT t (First NodeId) - (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))]) + { unLayout :: EventWriterT t (First (NodeId, Int)) + (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint), Dynamic t LayoutTree, Int)]) (ReaderT (LayoutCtx t) (VtyWidget t m))) a } deriving @@ -90,70 +125,163 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e +findNearestFloor_ :: (Ord k) => k -> (k, a) -> (k, a) -> Map k a -> Maybe (k, a) +findNearestFloor_ target leftValue parent Map.Tip = if target < fst leftValue + then Nothing -- error $ "Map.findNearestFloorSure: map has no element <= " <> show target + else if target < fst parent + then Just leftValue + else Just parent +findNearestFloor_ target leftValue _ (Map.Bin _ k a l r) = if target == k + then Just (k, a) + else if target < k + then findNearestFloor_ target leftValue (k, a) l + else findNearestFloor_ target (k, a) (k, a) r + +findNearestFloor :: (Ord k) => k -> Map k a -> Maybe (k,a) +findNearestFloor _ Map.Tip = Nothing +-- TODO I don't think we need to do findMin here, just pass in (k,x) as a placeholder value +findNearestFloor target m@(Map.Bin _ k x _ _) = findNearestFloor_ target (Map.findMin m) (k, x) m + +fanFocusEv :: (Reflex t) => Behavior t (Maybe (NodeId, Int)) -> Event t (Maybe (NodeId, Int)) -> EventSelector t (Const2 NodeId (Maybe Int)) +fanFocusEv focussed focusReqIx = fan $ attachWith attachfn focussed focusReqIx where + attachfn mkv0 mkv1 = case mkv1 of + Nothing -> case mkv0 of + Nothing -> DMap.empty + Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing] + Just (k1,v1) -> case mkv0 of + Nothing -> DMap.fromList [Const2 k1 :=> Identity (Just v1)] + Just (k0,v0) | k0 == k1 && v0 == v1 -> DMap.empty + Just (k0,_) | k0 == k1 -> DMap.fromList [Const2 k1 :=> Identity (Just v1)] + Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing, + Const2 k1 :=> Identity (Just v1)] + + +translateLayoutTree :: (Reflex t) => Orientation -> NodeId -> Dynamic t (Map NodeId LayoutSegment) -> Dynamic t LayoutTree -> Dynamic t LayoutTree +translateLayoutTree orient nid solutionMap dlt = ffor2 solutionMap dlt fn where + fn sm lt = result where + ls = fromMaybe (error "expected result") (Map.lookup nid sm) + result = ffor lt $ \reg -> if orient == Orientation_Row + then offsetRegion (_layoutSegment_offset ls, 0) reg + else offsetRegion (0, _layoutSegment_offset ls) reg + -- | Run a 'Layout' action -runLayout - :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m) +runLayoutL + :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout' - -> Int -- ^ The positional index of the initially focused tile - -> Event t Int -- ^ An event that shifts focus by a given number of tiles + -> Maybe Int -- ^ The positional index of the initially focused tile_ -> Layout t m a -- ^ The 'Layout' widget - -> VtyWidget t m a -runLayout ddir focus0 focusShift (Layout child) = do + -> LayoutVtyWidget t m (LayoutReturnData t a) +runLayoutL ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx -> mdo dw <- displayWidth dh <- displayHeight let main = ffor3 ddir dw dh $ \d w h -> case d of Orientation_Column -> h - Orientation_Row -> w - pb <- getPostBuild - rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir - let queries = flip appEndo [] <$> queriesEndo - solution = ffor2 main queries $ \sz qs -> Map.fromList - . Map.elems - . computeEdges - . computeSizes sz - . fmap (fmap snd) - . Map.fromList - . zip [0::Integer ..] - $ qs - solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment - { _layoutSegment_offset = offset - , _layoutSegment_size = sz - } - focusable = fmap (Bimap.fromList . zip [0..]) $ - ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) -> - if f then Just nodeId else Nothing - adjustFocus - :: (Bimap Int NodeId, (Int, Maybe NodeId)) - -> Either Int NodeId - -> (Int, Maybe NodeId) - adjustFocus (fm, (cur, _)) (Left shift) = - let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm) - in (ix, Bimap.lookup ix fm) - adjustFocus (fm, (cur, _)) (Right goto) = - let ix = fromMaybe cur $ Bimap.lookupR goto fm - in (ix, Just goto) - focusChange = attachWith - adjustFocus - (current $ (,) <$> focusable <*> focussed) - $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq] - -- A pair (Int, Maybe NodeId) which represents the index - -- that we're trying to focus, and the node that actually gets - -- focused (at that index) if it exists - focussed <- holdDyn (focus0, Nothing) focusChange - let focusDemux = demux $ snd <$> focussed - return a + Orientation_Row -> w + ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMapDyn focusDemux ddir focusChildSelector + let queries = flip appEndo [] <$> queriesEndo + solution = ffor2 main queries $ \sz qs -> Map.fromList + . Map.elems + . computeEdges + . computeSizes sz + . fmap (\(nodeid,(_,constraint),_,_) -> (nodeid,constraint)) + . Map.fromList + . zip [0::Integer ..] + $ qs + solutionMapDyn = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment + { _layoutSegment_offset = offset + , _layoutSegment_size = sz + } --- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint --- on its size and ability to grow and on whether it can be focused. It also allows its child --- widget to request focus. -tile - :: (Reflex t, Monad m, MonadNodeId m) - => TileConfig t -- ^ The tile's configuration - -> VtyWidget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused. + + focusableMapAccumFn acc (nid, (_, _), _, nc) = (nextAcc, value) where + nextAcc = acc + nc + value = (acc, nid) + focusable = fmap (Bimap.fromList . snd . mapAccumL focusableMapAccumFn 0) $ + ffor queries $ \qs -> fforMaybe qs $ \n@(_, (f, _), _, nc) -> + if f && nc > 0 then Just n else Nothing + + -- ix is focus in self index space + -- fst of return value is child node id to focus + -- snd of return value is focus in child's index space + findChildFocus :: Bimap Int NodeId -> Int -> Maybe (NodeId, Int) + findChildFocus fm ix = findNearestFloor ix (Bimap.toMap fm) >>= \(ixl, t) -> Just (t, ix-ixl) + + adjustFocus + :: (Bimap Int NodeId) + -> Either (Maybe Int) (NodeId, Int) -- left is self index, right is (child id, child index) + -> Maybe (Int, (NodeId, Int)) -- fst is self index, snd is (child id, child index) + adjustFocus fm (Left (Just ix)) = do + x <- findChildFocus fm ix + return (ix, x) + adjustFocus fm (Left Nothing) = Nothing + adjustFocus fm (Right (goto, ixrel)) = do + ix <- Bimap.lookupR goto fm + return (ix+ixrel, (goto, ixrel)) + + focusChange = attachWith adjustFocus (current focusable) + -- TODO handle Nothing case in both places (so that event produces Nothing in this case) + $ leftmost [ fmap Right . fmap getFirst $ focusReq, Left <$> focusReqIx] + + let + forestDyn :: Dynamic t [LayoutTree] = join . fmap distributeListOverDyn $ ffor2 queries ddir $ \qs dir -> ffor qs $ \(nid,_,dlt,_) -> translateLayoutTree dir nid solutionMapDyn dlt + layoutTreeDyn :: Dynamic t LayoutTree = ffor3 forestDyn dw dh $ \f w h -> Tree.Node (Region 0 0 w h) f + + fm0 <- sample . current $ focusable + -- TODO this is dependent on focusable-ness of children so _layoutReturnData_children should be changed to dynamic... + -- TODO consider removing dynamic from focus/constraint instead + let totalKiddos = fmap (sum . fmap (\(_,(f, _),_,k) -> if f then k else 0)) queries + + -- brief explanation of overly complicated focus tracking + -- focus is propogated in 2 ways + -- focusReq (focus from bottom up) + -- focusReqIx (focus from top down) + -- focussed tracks the focus state + -- focusDemux is used to pass the 'pane's of immediate children + + -- fst is index we want to focus in self index space, snd is node id we want to focus + focussed :: Dynamic t (Maybe (Int, (NodeId, Int))) <- holdDyn initialFocus (focusChange) + let + initialFocus :: Maybe (Int, (NodeId, Int)) = do + f0 <- mfocus0 + cf0 <- findChildFocus fm0 f0 + return (f0, cf0) + + focussedForDemux = fmap (fmap (fst . snd)) focussed + focusDemux :: Demux t (Maybe NodeId) = demux focussedForDemux + + focusReqWithNodeId :: Event t (Maybe (NodeId, Int)) + focusReqWithNodeId = attachWith (\fm mix -> mix >>= \ix -> findChildFocus fm ix) (current focusable) (focusReqIx) + focusChildSelector = fanFocusEv (current $ fmap (fmap snd) focussed) (focusReqWithNodeId) + + return LayoutReturnData { + _layoutReturnData_tree = layoutTreeDyn + , _layoutReturnData_focus = (fmap (fmap fst)) focussed + , _layoutReturnData_children = totalKiddos + , _layoutReturnData_value = a + } + +-- | Run a 'Layout' action +runLayout + :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, Monad m, MonadNodeId m) + => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout' + -> Maybe Int -- ^ The positional index of the initially focused tile_ + -> Layout t m a -- ^ The 'Layout' widget + -> LayoutVtyWidget t m a +runLayout ddir mfocus0 layout = fmap _layoutReturnData_value $ runLayoutL ddir mfocus0 layout + +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) + +tile_ + :: forall t b widget m a x. (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m) + => TileConfig t -- ^ The tile_'s configuration + -> widget t m (Event t x, b) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused. -> Layout t m a -tile (TileConfig con focusable) child = do +tile_ (TileConfig con focusable) child = mdo nodeId <- getNextNodeId - Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):) + -- by calling getLayoutTree/getLayoutNumChildren here, we store the children's layout info inside the DynamicWriter + -- runLayoutL will extract this info later + Layout $ tellDyn $ ffor3 con focusable nKiddosDyn $ \c f n -> Endo ((nodeId, (f, c), getLayoutTree @t @b @a b, n):) seg <- Layout $ asks $ fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions dw <- displayWidth @@ -176,58 +304,108 @@ tile (TileConfig con focusable) child = do Orientation_Column -> _layoutSegment_size s Orientation_Row -> c } - focussed <- Layout $ asks _layoutCtx_focusDemux - (focusReq, a) <- Layout $ lift $ lift $ lift $ - pane reg (demuxed focussed $ Just nodeId) $ child - Layout $ tellEvent $ First nodeId <$ focusReq - return a + let nKiddosDyn = getLayoutNumChildren @t @b @a b --- | Configuration options for and constraints on 'tile' + focusChildSelector <- Layout $ asks _layoutCtx_focusChildSelector + let focusChildEv = select focusChildSelector (Const2 nodeId) + focussed <- Layout $ asks _layoutCtx_focusSelfDemux + (focusReq, b) <- Layout $ lift $ lift $ lift $ + pane reg (demuxed focussed $ Just nodeId) $ runIsLayoutVtyWidget child (focusChildEv) + Layout $ tellEvent $ + gate (fmap (>0) (current nKiddosDyn)) + . fmap (First . swap) + $ attachPromptlyDyn (fmap (fromMaybe 0) $ getLayoutFocussedDyn @t @b @a b) (nodeId <$ focusReq) + return $ getLayoutResult @t b + +-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint +-- on its size and ability to grow and on whether it can be focused. It also allows its child +-- widget to request focus. +tile + :: (Reflex t, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m) + => TileConfig t -- ^ The tile's configuration + -> widget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused. + -> Layout t m a +tile = tile_ + + +-- | Configuration options for and constraints on 'tile_' data TileConfig t = TileConfig { _tileConfig_constraint :: Dynamic t Constraint - -- ^ 'Constraint' on the tile's size - , _tileConfig_focusable :: Dynamic t Bool - -- ^ Whether the tile is focusable + -- ^ 'Constraint' on the tile_'s size + , _tile_Config_focusable :: Dynamic t Bool + -- ^ Whether the tile_ is focusable } instance Reflex t => Default (TileConfig t) where def = TileConfig (pure $ Constraint_Min 0) (pure True) + +fixed_ + :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m) + => Dynamic t Int + -> widget t m b + -> Layout t m a +fixed_ sz = tile_ (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable + +-- | Use this variant to start a sub layout. +fixedL + :: (Reflex t, MonadFix m, MonadNodeId m) + => Dynamic t Int + -> LayoutVtyWidget t m (LayoutReturnData t a) + -> Layout t m a +fixedL = fixed_ + -- | A 'tile' of a fixed size that is focusable and gains focus on click fixed - :: (Reflex t, Monad m, MonadNodeId m) + :: (Reflex t, MonadFix m, MonadNodeId m) => Dynamic t Int -> VtyWidget t m a -> Layout t m a -fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable +fixed = fixed_ + +stretch_ + :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m) + => widget t m b + -> Layout t m a +stretch_ = tile_ def . clickable + +-- | Use this variant to start a sub layout. +stretchL + :: (Reflex t, MonadFix m, MonadNodeId m) + => LayoutVtyWidget t m (LayoutReturnData t a) + -> Layout t m a +stretchL = stretch_ -- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0. -- This tile is focusable and gains focus on click. stretch - :: (Reflex t, Monad m, MonadNodeId m) + :: (Reflex t, MonadFix m, MonadNodeId m) => VtyWidget t m a -> Layout t m a -stretch = tile def . clickable +stretch = stretch_ --- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to --- change tile focus. +-- | A version of 'runLayout' that arranges tiles in a column col - :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m) + :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m) => Layout t m a - -> VtyWidget t m a -col child = do - nav <- tabNavigation - runLayout (pure Orientation_Column) 0 nav child + -> LayoutVtyWidget t m (LayoutReturnData t a) +col child = runLayoutL (pure Orientation_Column) (Nothing) child --- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to --- change tile focus. +-- | A version of 'runLayout' that arranges tiles in a row row - :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m) + :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m) => Layout t m a - -> VtyWidget t m a -row child = do - nav <- tabNavigation - runLayout (pure Orientation_Row) 0 nav child + -> LayoutVtyWidget t m (LayoutReturnData t a) +row child = runLayoutL (pure Orientation_Row) (Nothing) child + +-- | Use to make placeholder empty cells in sub layouts. +dummyCell :: (Reflex t, Monad m) => (Reflex t) => LayoutVtyWidget t m (LayoutReturnData t ()) +dummyCell = return LayoutReturnData { + _layoutReturnData_tree = constDyn emptyLayoutTree + , _layoutReturnData_focus = constDyn Nothing + , _layoutReturnData_children = 0 + , _layoutReturnData_value = () + } -- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed -- and backward one tile when Shift+Tab is pressed. @@ -240,14 +418,67 @@ tabNavigation = do -- | Captures the click event in a 'VtyWidget' context and returns it. Useful for -- requesting focus when using 'tile'. clickable - :: (Reflex t, Monad m) - => VtyWidget t m a - -> VtyWidget t m (Event t (), a) -clickable child = do + :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m) + => widget t m a + -> LayoutVtyWidget t m (Event t (), a) +clickable child = LayoutVtyWidget . ReaderT $ \focusEv -> do click <- mouseDown V.BLeft - a <- child + a <- runIsLayoutVtyWidget child focusEv return (() <$ click, a) +-- | create a focus event (to be used with runIsLayoutVtyWidget) from a navigation event +layoutFocusEvFromNavigation + :: (Reflex t) + => Event t Int + -> Event t () + -> LayoutReturnData t a + -> Event t (Maybe Int) +layoutFocusEvFromNavigation navEv unfocusEv LayoutReturnData {..} = r where + fmapfn (nKiddos, (mcur, shift)) = maybe (Just 0) (\cur -> Just $ (shift + cur) `mod` nKiddos) mcur + navEv' = attach (current _layoutReturnData_children) $ attach (current _layoutReturnData_focus) navEv + r = leftmost [unfocusEv $> Nothing, fmap fmapfn navEv'] + +-- TODO look into making a variant of this function that takes a navigation event +-- | Use this variant to begin a layout if you need its "LayoutReturnData" +beginLayoutL + :: (Reflex t, MonadHold t m, MonadFix m) + => LayoutVtyWidget t m (LayoutReturnData t a) + -> VtyWidget t m (LayoutReturnData t a) +beginLayoutL child = mdo + -- TODO consider unfocusing if this loses focus + --focussed <- focus + tabEv <- tabNavigation + let + focusChildEv = layoutFocusEvFromNavigation tabEv never lrd + lrd <- runIsLayoutVtyWidget child focusChildEv + return lrd + +-- | Begin a layout using tab and shift-tab to navigate +beginLayout + :: (Reflex t, MonadHold t m, MonadFix m) + => LayoutVtyWidget t m (LayoutReturnData t a) + -> VtyWidget t m a +beginLayout = fmap _layoutReturnData_value . beginLayoutL + + +{- something like this +beginLayoutL + :: (Reflex t, MonadHold t m, MonadFix m) + => LayoutVtyWidget t m (LayoutReturnData t a) + -> Maybe (Event t Int) + -> VtyWidget t m (LayoutReturnData t a) +beginLayoutL mNavEv child = mdo + -- TODO consider unfocusing if this loses focus + --focussed <- focus + let + focusChildEv = case mNavEv of + Just navEv -> layoutFocusEvFromNavigation navEv never lrd + Nothing -> never + lrd <- runIsLayoutVtyWidget child focusChildEv + return lrd +-} + + -- | Retrieve the current orientation of a 'Layout' askOrientation :: Monad m => Layout t m (Dynamic t Orientation) askOrientation = Layout $ asks _layoutCtx_orientation @@ -259,8 +490,7 @@ data Constraint = Constraint_Fixed Int -- | Compute the size of each widget "@k@" based on the total set of 'Constraint's computeSizes - :: Ord k - => Int + :: Int -> Map k (a, Constraint) -> Map k (a, Int) computeSizes available constraints = @@ -273,13 +503,102 @@ computeSizes available constraints = adjustment = max 0 $ available - minTotal - szStretch * numStretch in snd $ Map.mapAccum (\adj (a, c) -> case c of Constraint_Fixed n -> (adj, (a, n)) - Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints + Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints where isMin (Constraint_Min _) = True - isMin _ = False + isMin _ = False computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int)) computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) -> (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0) + +offsetRegion :: (Int, Int) -> Region -> Region +offsetRegion (x,y) reg = reg { + _region_left = x+x' + , _region_top = y+y' + } where + x' = _region_left reg + y' = _region_top reg + +-- | Dynamic sizing information on a layout hierarchy (intended for testing) +type LayoutTree = Tree.Tree Region + +emptyLayoutTree :: LayoutTree +emptyLayoutTree = Tree.Node (Region 0 0 0 0) [] + +dynLayoutTreeInDynRegion :: (Reflex t) => DynRegion t -> Dynamic t LayoutTree -> Dynamic t LayoutTree +dynLayoutTreeInDynRegion DynRegion {..} dlt = ffor3 _dynRegion_left _dynRegion_top dlt $ \x y lt -> fmap (offsetRegion (x,y)) lt + +infix 9 !!? +(!!?) :: [a] -> Int -> Maybe a +(!!?) xs i + | i < 0 = Nothing + | otherwise = go i xs + where + go :: Int -> [a] -> Maybe a + go 0 (x:_) = Just x + go j (_:ys) = go (j - 1) ys + go _ [] = Nothing +{-# INLINE (!!?) #-} + +-- | gives top left corner of the cell following directions +layoutTreeCellToPosition :: [Int] -> LayoutTree -> Maybe (Int, Int) +layoutTreeCellToPosition [] (Tree.Node region _) = Just (_region_left region, _region_top region) +layoutTreeCellToPosition (x:xs) (Tree.Node _ kiddos) = kiddos !!? x >>= layoutTreeCellToPosition xs + +class IsLayoutReturn t b a where + getLayoutResult :: b -> a + getLayoutNumChildren :: b -> Dynamic t Int + getLayoutFocussedDyn :: b -> Dynamic t (Maybe Int) + getLayoutTree :: b -> Dynamic t LayoutTree + +data LayoutReturnData t a = LayoutReturnData { + _layoutReturnData_tree :: Dynamic t LayoutTree + , _layoutReturnData_focus :: Dynamic t (Maybe Int) + , _layoutReturnData_children :: Dynamic t Int + , _layoutReturnData_value :: a + } + +instance IsLayoutReturn t (LayoutReturnData t a) a where + getLayoutResult lrd = _layoutReturnData_value lrd + getLayoutNumChildren lrd = _layoutReturnData_children lrd + getLayoutFocussedDyn lrd = _layoutReturnData_focus lrd + getLayoutTree lrd = _layoutReturnData_tree lrd + +instance Reflex t => IsLayoutReturn t a a where + getLayoutResult = id + getLayoutNumChildren _ = 1 + getLayoutFocussedDyn _ = constDyn Nothing + getLayoutTree _ = constDyn emptyLayoutTree + +class IsLayoutVtyWidget l t m where + runIsLayoutVtyWidget :: l t m a -> Event t (Maybe Int) -> VtyWidget t m a + +newtype LayoutVtyWidget t m a = LayoutVtyWidget { + unLayoutVtyWidget :: ReaderT (Event t (Maybe Int)) (VtyWidget t m) a + } deriving + ( Functor + , Applicative + , Monad + , MonadHold t + , MonadSample t + , MonadFix + , TriggerEvent t + , PerformEvent t + , NotReady t + , MonadReflexCreateTrigger t + , HasDisplaySize t + , MonadNodeId + , PostBuild t + ) + +instance MonadTrans (LayoutVtyWidget t) where + lift x = LayoutVtyWidget $ lift $ lift x + +instance IsLayoutVtyWidget VtyWidget t m where + runIsLayoutVtyWidget w _ = w + +instance IsLayoutVtyWidget LayoutVtyWidget t m where + runIsLayoutVtyWidget = runReaderT . unLayoutVtyWidget