From f2c798e339b2658883ce0d5f96a37bd018ffe2b3 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Fri, 3 Jan 2020 00:20:03 -0300 Subject: [PATCH] Handle node visibility --- app/Main.hs | 16 ++++++++-------- src/GUI/Common/Core.hs | 29 +++++++++++++++++++++-------- src/GUI/Widget/Button.hs | 2 +- src/GUI/Widget/Grid.hs | 19 +++++++++++-------- src/GUI/Widget/Label.hs | 2 +- src/GUI/Widget/Sandbox.hs | 2 +- src/GUI/Widget/Scroll.hs | 2 +- src/GUI/Widget/Spacer.hs | 2 +- src/GUI/Widget/Stack.hs | 13 ++++++++----- src/GUI/Widget/TextField.hs | 2 +- 10 files changed, 54 insertions(+), 35 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index fde74acb..e9bd77f2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -136,17 +136,17 @@ buildUI model = styledTree where labelStyle = bgColor (rgb 100 100 100) <> textSize 48 textStyle = textColor (rgb 0 255 0) extraWidgets = map (\i -> sandbox (Action1 (10 + i))) [1..(_clickCount model)] - widgetTree = vgrid [ + widgetTree = vstack [ hgrid [ scroll $ vstack [ - textField `style` textStyle, - spacer, + textField `style` textStyle `visible` False, + spacer `visible` False, label "Label 1", spacer, label "Label 2", - spacer, - label "Label 3", - spacer, + spacer `visible` False, + label "Label 3" `visible` False, + spacer `visible` False, label "Label 4", spacer, label "Label 5", @@ -165,7 +165,7 @@ buildUI model = styledTree where spacer, label "Label 12" ], - vgrid [ + vstack [ textField `style` textStyle, scroll $ label "This is a really really really long label, you know?" `style` labelStyle ] @@ -184,7 +184,7 @@ buildUI model = styledTree where spacer, label "Very Very Very Very Long" ], - hgrid [ + hstack [ sandbox (Action1 1) `style` buttonStyle, sandbox (Action1 2) `style` buttonStyle, sandbox (Action1 3) `style` buttonStyle diff --git a/src/GUI/Common/Core.hs b/src/GUI/Common/Core.hs index b4131522..8b1a65ee 100644 --- a/src/GUI/Common/Core.hs +++ b/src/GUI/Common/Core.hs @@ -36,7 +36,7 @@ type Timestamp = Int type WidgetNode s e m = Tree (WidgetInstance s e m) type WidgetChildren s e m = SQ.Seq (WidgetNode s e m) -newtype WidgetType = WidgetType String deriving Eq +newtype WidgetType = WidgetType String deriving (Eq, Show) newtype WidgetKey = WidgetKey String deriving Eq instance IsString WidgetType where @@ -50,7 +50,8 @@ data WidgetState = forall i . (Typeable i, Generic i) => WidgetState i data SizeReq = SizeReq { _srSize :: Size, _srPolicyWidth :: SizePolicy, - _srPolicyHeight :: SizePolicy + _srPolicyHeight :: SizePolicy, + _srVisible :: Bool } deriving (Show, Eq) data WidgetEventResult s e m = WidgetEventResult { @@ -143,6 +144,8 @@ data WidgetInstance s e m = _widgetInstanceWidget :: Widget s e m, -- | Indicates if the widget is enabled for user interaction _widgetInstanceEnabled :: Bool, + -- | Indicates if the widget is visible + _widgetInstanceVisible :: Bool, -- | Indicates if the widget is focused _widgetInstanceFocused :: Bool, -- | The visible area of the screen assigned to the widget @@ -174,6 +177,9 @@ initGUIContext app winSize useHiDPI devicePixelRate = GUIContext { _widgetTasks = [] } +sizeReq :: Size -> SizePolicy -> SizePolicy -> SizeReq +sizeReq size policyWidth policyHeight = SizeReq size policyWidth policyHeight True + resultEvents :: [e] -> Maybe (WidgetEventResult s e m) resultEvents userEvents = Just $ WidgetEventResult [] userEvents Nothing @@ -207,6 +213,9 @@ key key wn = wn { _widgetInstanceKey = Just key } style :: (MonadState s m) => WidgetNode s e m -> Style -> WidgetNode s e m style (Node value children) newStyle = Node (value { _widgetInstanceStyle = newStyle }) children +visible :: (MonadState s m) => WidgetNode s e m -> Bool -> WidgetNode s e m +visible (Node value children) visibility = Node (value { _widgetInstanceVisible = visibility }) children + children :: (MonadState s m) => WidgetNode s e m -> [WidgetNode s e m] -> WidgetNode s e m children (Node value _) newChildren = fromList value newChildren @@ -221,6 +230,7 @@ defaultWidgetInstance widget = WidgetInstance { _widgetInstanceKey = Nothing, _widgetInstanceWidget = widget, _widgetInstanceEnabled = True, + _widgetInstanceVisible = True, _widgetInstanceFocused = False, _widgetInstanceViewport = def, _widgetInstanceRenderArea = def, @@ -310,7 +320,8 @@ handleCustomCommand path treeNode customData = case GUI.Data.Tree.lookup path tr handleRender :: (MonadState s m) => Renderer m -> WidgetNode s e m -> Timestamp -> m () handleRender renderer (Node (widgetInstance@WidgetInstance { _widgetInstanceWidget = Widget{..}, .. }) children) ts = do - _widgetRender renderer widgetInstance children ts + when _widgetInstanceVisible $ + _widgetRender renderer widgetInstance children ts handleRenderChildren :: (MonadState s m) => Renderer m -> WidgetChildren s e m -> Timestamp -> m () handleRenderChildren renderer children ts = do @@ -330,15 +341,17 @@ setFocusedStatus path focused root = case updateWidgetInstance path root updateF resizeUI :: (MonadState s m) => Renderer m -> Rect -> WidgetNode s e m -> m (WidgetNode s e m) resizeUI renderer assignedRect widgetInstance = do - preferredSizes <- buildPreferredSizes renderer widgetInstance + preferredSizes <- buildPreferredSizes renderer True widgetInstance resizeNode renderer assignedRect assignedRect preferredSizes widgetInstance -buildPreferredSizes :: (MonadState s m) => Renderer m -> WidgetNode s e m -> m (Tree SizeReq) -buildPreferredSizes renderer (Node (WidgetInstance {..}) children) = do - childrenSizes <- mapM (buildPreferredSizes renderer) children +buildPreferredSizes :: (MonadState s m) => Renderer m -> Bool -> WidgetNode s e m -> m (Tree SizeReq) +buildPreferredSizes renderer parentVisible (Node (WidgetInstance {..}) children) = do + let isVisible = parentVisible && _widgetInstanceVisible + + childrenSizes <- mapM (buildPreferredSizes renderer isVisible) children size <- _widgetPreferredSize _widgetInstanceWidget renderer _widgetInstanceStyle (seqToList childrenSizes) - return $ Node size childrenSizes + return $ Node (size { _srVisible = isVisible}) childrenSizes resizeNode :: (MonadState s m) => Renderer m -> Rect -> Rect -> Tree SizeReq -> WidgetNode s e m -> m (WidgetNode s e m) resizeNode renderer viewport renderArea (Node _ childrenSizes) (Node widgetInstance childrenWns) = do diff --git a/src/GUI/Widget/Button.hs b/src/GUI/Widget/Button.hs index 571f0515..ef94561b 100644 --- a/src/GUI/Widget/Button.hs +++ b/src/GUI/Widget/Button.hs @@ -40,7 +40,7 @@ makeButton label onClick = Widget { _ -> Nothing preferredSize renderer (style@Style{..}) _ = do size <- calcTextBounds renderer _textStyle label - return $ SizeReq size FlexibleSize FlexibleSize + return $ sizeReq size FlexibleSize FlexibleSize resizeChildren _ _ _ _ = Nothing render renderer WidgetInstance{..} _ ts = do diff --git a/src/GUI/Widget/Grid.hs b/src/GUI/Widget/Grid.hs index c527cd1c..f5eca204 100644 --- a/src/GUI/Widget/Grid.hs +++ b/src/GUI/Widget/Grid.hs @@ -46,19 +46,22 @@ makeFixedGrid widgetType direction = Widget { focusable = False handleEvent _ _ = Nothing preferredSize _ _ children = return reqSize where - reqSize = SizeReq (Size width height) FlexibleSize FlexibleSize + reqSize = sizeReq (Size width height) FlexibleSize FlexibleSize width = if null children then 0 else (fromIntegral wMul) * (maximum . map (_w . _srSize)) children height = if null children then 0 else (fromIntegral hMul) * (maximum . map (_h . _srSize)) children wMul = if direction == Horizontal then length children else 1 hMul = if direction == Horizontal then 1 else length children resizeChildren _ (Rect l t w h) style children = Just $ WidgetResizeResult newViewports newViewports Nothing where - cols = if direction == Horizontal then (length children) else 1 - rows = if direction == Horizontal then 1 else (length children) - newViewports = fmap resizeChild [0..(length children - 1)] + visibleChildren = filter _srVisible children + cols = if direction == Horizontal then (length visibleChildren) else 1 + rows = if direction == Horizontal then 1 else (length visibleChildren) + foldHelper (accum, index) child = (index : accum, index + if _srVisible child then 1 else 0) + indices = reverse . fst $ foldl foldHelper ([], 0) children + newViewports = fmap resizeChild indices resizeChild i = Rect (cx i) (cy i) cw ch - cw = w / fromIntegral cols - ch = h / fromIntegral rows - cx i = l + (fromIntegral $ i `div` rows) * cw - cy i = t + (fromIntegral $ i `div` cols) * ch + cw = if cols > 0 then w / fromIntegral cols else 0 + ch = if rows > 0 then h / fromIntegral rows else 0 + cx i = if rows > 0 then l + (fromIntegral $ i `div` rows) * cw else 0 + cy i = if cols > 0 then t + (fromIntegral $ i `div` cols) * ch else 0 render renderer WidgetInstance{..} children ts = do handleRenderChildren renderer children ts diff --git a/src/GUI/Widget/Label.hs b/src/GUI/Widget/Label.hs index 7bb297da..48fe7fca 100644 --- a/src/GUI/Widget/Label.hs +++ b/src/GUI/Widget/Label.hs @@ -41,7 +41,7 @@ makeLabel caption = Widget { handleEvent view evt = Nothing preferredSize renderer (style@Style{..}) _ = do size <- calcTextBounds renderer _textStyle (if caption == "" then " " else caption) - return $ SizeReq size FlexibleSize FlexibleSize + return $ sizeReq size FlexibleSize FlexibleSize resizeChildren _ _ _ _ = Nothing render renderer WidgetInstance{..} _ ts = do diff --git a/src/GUI/Widget/Sandbox.hs b/src/GUI/Widget/Sandbox.hs index a4052bb4..da9fa3f5 100644 --- a/src/GUI/Widget/Sandbox.hs +++ b/src/GUI/Widget/Sandbox.hs @@ -57,7 +57,7 @@ makeSandbox state onClick = Widget { Nothing -> Nothing preferredSize renderer (style@Style{..}) _ = do size <- calcTextBounds renderer _textStyle (T.pack (show (_clickCount state))) - return $ SizeReq size FlexibleSize FlexibleSize + return $ sizeReq size FlexibleSize FlexibleSize resizeChildren _ _ _ _ = Nothing render renderer WidgetInstance{..} _ ts = do diff --git a/src/GUI/Widget/Scroll.hs b/src/GUI/Widget/Scroll.hs index 20bafbd2..b079f909 100644 --- a/src/GUI/Widget/Scroll.hs +++ b/src/GUI/Widget/Scroll.hs @@ -74,7 +74,7 @@ makeScroll state@(ScrollState dx dy cs@(Size cw ch)) = Widget { else viewportLimit - childPos preferredSize _ _ children = return (head children) resizeChildren (Rect l t w h) _ _ children = Just $ WidgetResizeResult viewport renderArea newWidget where - SizeReq (Size cw2 ch2) _ _ = (head children) + Size cw2 ch2 = _srSize (head children) areaW = max w cw2 areaH = max h ch2 newWidget = Just $ makeScroll (ScrollState dx dy (Size areaW areaH)) diff --git a/src/GUI/Widget/Spacer.hs b/src/GUI/Widget/Spacer.hs index d89b32d6..c55c9550 100644 --- a/src/GUI/Widget/Spacer.hs +++ b/src/GUI/Widget/Spacer.hs @@ -30,6 +30,6 @@ makeSpacer = Widget { } where handleEvent view evt = Nothing - preferredSize renderer (style@Style{..}) _ = return $ SizeReq (Size defaultSpace defaultSpace) RemainderSize RemainderSize + preferredSize renderer (style@Style{..}) _ = return $ sizeReq (Size defaultSpace defaultSpace) RemainderSize RemainderSize resizeChildren _ _ _ _ = Nothing render renderer WidgetInstance{..} _ ts = return () diff --git a/src/GUI/Widget/Stack.hs b/src/GUI/Widget/Stack.hs index 7ee78a08..512611c7 100644 --- a/src/GUI/Widget/Stack.hs +++ b/src/GUI/Widget/Stack.hs @@ -41,16 +41,17 @@ makeStack widgetType direction = Widget { focusable = False handleEvent _ _ = Nothing preferredSize _ _ children = return reqSize where - reqSize = SizeReq (calcPreferredSize children) FlexibleSize FlexibleSize + reqSize = sizeReq (calcPreferredSize children) FlexibleSize FlexibleSize resizeChildren _ (Rect l t w h) style children = Just $ WidgetResizeResult newViewports newViewports Nothing where + visibleChildren = filter _srVisible children policySelector = if isHorizontal then _srPolicyWidth else _srPolicyHeight sizeSelector = if isHorizontal then _w else _h rectSelector = if isHorizontal then _rw else _rh mSize = if isHorizontal then w else h mStart = if isHorizontal then l else t - sChildren = filter (\c -> policySelector c == StrictSize) children - fChildren = filter (\c -> policySelector c == FlexibleSize) children - rChildren = filter (\c -> policySelector c == RemainderSize) children + sChildren = filter (\c -> policySelector c == StrictSize) visibleChildren + fChildren = filter (\c -> policySelector c == FlexibleSize) visibleChildren + rChildren = filter (\c -> policySelector c == RemainderSize) visibleChildren remainderCount = length rChildren remainderExist = not $ null rChildren sSize = sizeSelector $ calcPreferredSize sChildren @@ -65,7 +66,9 @@ makeStack widgetType direction = Widget { (revViewports, _) = foldl foldHelper ([], mStart) children foldHelper (accum, offset) child = (newSize : accum, offset + rectSelector newSize) where newSize = resizeChild offset child - resizeChild offset sr@(SizeReq srSize _ _) = if isHorizontal then hRect else vRect where + resizeChild offset sr = if not (_srVisible sr) then emptyRect else if isHorizontal then hRect else vRect where + srSize = _srSize sr + emptyRect = Rect l t 0 0 hRect = Rect offset t newSize h vRect = Rect l offset w newSize newSize = case policySelector sr of diff --git a/src/GUI/Widget/TextField.hs b/src/GUI/Widget/TextField.hs index 2085af41..6baa3c3a 100644 --- a/src/GUI/Widget/TextField.hs +++ b/src/GUI/Widget/TextField.hs @@ -72,7 +72,7 @@ makeTextField tfs@(TextFieldState currText currPos) = Widget { newState = TextFieldState newText newPos preferredSize renderer (style@Style{..}) _ = do size <- calcTextBounds renderer _textStyle (if currText == "" then " " else currText) - return $ SizeReq size FlexibleSize FlexibleSize + return $ sizeReq size FlexibleSize FlexibleSize resizeChildren _ _ _ _ = Nothing render renderer WidgetInstance{..} _ ts = do