From 2c2ce9408027e1e07d7a676ece9c346a642f0eec Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Wed, 11 Dec 2019 23:51:58 -0300 Subject: [PATCH] Add state save/restore handling --- src/GUI/Widget/Button.hs | 2 ++ src/GUI/Widget/Core.hs | 39 +++++++++++++++++++++++++++++++------ src/GUI/Widget/Label.hs | 2 ++ src/GUI/Widget/Layout.hs | 2 ++ src/GUI/Widget/Sandbox.hs | 18 ++++++++++++----- src/GUI/Widget/Scroll.hs | 8 +++++++- src/GUI/Widget/TextField.hs | 11 +++++++++-- 7 files changed, 68 insertions(+), 14 deletions(-) diff --git a/src/GUI/Widget/Button.hs b/src/GUI/Widget/Button.hs index 1163072d..ba1700d1 100644 --- a/src/GUI/Widget/Button.hs +++ b/src/GUI/Widget/Button.hs @@ -25,6 +25,8 @@ makeButton :: (MonadState s m, MonadIO m) => T.Text -> e -> Widget s e m makeButton label onClick = Widget { _widgetType = "button", _widgetFocusable = False, + _widgetRestoreState = defaultRestoreState, + _widgetSaveState = defaultSaveState, _widgetHandleEvent = handleEvent, _widgetHandleCustom = defaultCustomHandler, _widgetPreferredSize = preferredSize, diff --git a/src/GUI/Widget/Core.hs b/src/GUI/Widget/Core.hs index 054d366c..ff9feed9 100644 --- a/src/GUI/Widget/Core.hs +++ b/src/GUI/Widget/Core.hs @@ -14,6 +14,7 @@ import Control.Monad import Control.Monad.State import Data.Default +import Data.Dynamic import Data.Maybe import Data.String import Data.Typeable (cast, Typeable) @@ -24,6 +25,8 @@ import GUI.Common.Core import GUI.Common.Style import GUI.Data.Tree +import GHC.Generics + import qualified Data.Text as T import qualified Data.Sequence as SQ @@ -119,12 +122,30 @@ isFocusable (WidgetInstance { _widgetInstanceWidget = Widget{..}, ..}) = _widget defaultCustomHandler :: a -> Maybe (WidgetEventResult s e m) defaultCustomHandler _ = Nothing +data WidgetState = forall i . (Typeable i, Generic i) => WidgetState i + +defaultRestoreState :: WidgetState -> Maybe (Widget s e m) +defaultRestoreState _ = Nothing + +defaultSaveState :: Maybe WidgetState +defaultSaveState = Nothing + +makeState :: (Typeable i, Generic i) => i -> Maybe WidgetState +makeState state = Just (WidgetState state) + +useState :: (Typeable i, Generic i) => WidgetState -> Maybe i +useState (WidgetState state) = cast state + data Widget s e m = (MonadState s m) => Widget { -- | Type of the widget _widgetType :: WidgetType, -- | Indicates whether the widget can receive focus _widgetFocusable :: Bool, + -- | Provides the previous internal state to the new widget, which can choose to ignore it or update itself + _widgetRestoreState :: WidgetState -> Maybe (Widget s e m), + -- | Returns the current internal state, which can later be used to restore the widget + _widgetSaveState :: Maybe WidgetState, -- | Handles an event -- -- Region assigned to the widget @@ -137,7 +158,7 @@ data Widget s e m = -- Result of asynchronous computation -- -- Returns: the list of generated events and, maybe, a new version of the widget if internal state changed - _widgetHandleCustom :: forall i . Typeable i => i -> Maybe (WidgetEventResult s e m), + _widgetHandleCustom :: forall i . Typeable i => i -> Maybe (WidgetEventResult s e m), -- | Minimum size desired by the widget -- -- Style options @@ -228,13 +249,19 @@ widgetMatches :: (MonadState s m) => WidgetInstance s e m -> WidgetInstance s e widgetMatches wn1 wn2 = _widgetType (_widgetInstanceWidget wn1) == _widgetType (_widgetInstanceWidget wn2) && _widgetInstanceKey wn1 == _widgetInstanceKey wn2 mergeTrees :: (MonadState s m) => WidgetNode s e m -> WidgetNode s e m -> WidgetNode s e m -mergeTrees node1@(Node widget1 seq1) (Node widget2 seq2) = newNode where - matches = widgetMatches widget1 widget2 - newNode = if | matches -> Node widget2 newChildren +mergeTrees node1@(Node candidateInstance candidateChildren) (Node oldInstance oldChildren) = newNode where + matches = widgetMatches candidateInstance oldInstance + newNode = if | matches -> Node newInstance newChildren | otherwise -> node1 + oldWidget = _widgetInstanceWidget oldInstance + candidateWidget = _widgetInstanceWidget candidateInstance + newWidget = case _widgetSaveState oldWidget of + Just st -> fromMaybe candidateWidget (_widgetRestoreState candidateWidget st) + Nothing -> candidateWidget + newInstance = candidateInstance { _widgetInstanceWidget = newWidget } newChildren = mergedChildren SQ.>< addedChildren - mergedChildren = fmap mergeChild (SQ.zip seq1 seq2) - addedChildren = SQ.drop (SQ.length seq2) seq1 + mergedChildren = fmap mergeChild (SQ.zip candidateChildren oldChildren) + addedChildren = SQ.drop (SQ.length oldChildren) candidateChildren mergeChild = \(c1, c2) -> mergeTrees c1 c2 handleWidgetEvents :: (MonadState s m) => Widget s e m -> Rect -> SystemEvent -> Maybe (WidgetEventResult s e m) diff --git a/src/GUI/Widget/Label.hs b/src/GUI/Widget/Label.hs index 4f08ec81..78b07360 100644 --- a/src/GUI/Widget/Label.hs +++ b/src/GUI/Widget/Label.hs @@ -31,6 +31,8 @@ makeLabel :: (MonadState s m) => T.Text -> Widget s e m makeLabel caption = Widget { _widgetType = "label", _widgetFocusable = False, + _widgetRestoreState = defaultRestoreState, + _widgetSaveState = defaultSaveState, _widgetHandleEvent = handleEvent, _widgetHandleCustom = defaultCustomHandler, _widgetPreferredSize = preferredSize, diff --git a/src/GUI/Widget/Layout.hs b/src/GUI/Widget/Layout.hs index a985daaf..94697592 100644 --- a/src/GUI/Widget/Layout.hs +++ b/src/GUI/Widget/Layout.hs @@ -35,6 +35,8 @@ makeFixedGrid :: (MonadState s m) => WidgetType -> Direction -> Widget s e m makeFixedGrid widgetType direction = Widget { _widgetType = widgetType, _widgetFocusable = False, + _widgetRestoreState = defaultRestoreState, + _widgetSaveState = defaultSaveState, _widgetHandleEvent = handleEvent, _widgetHandleCustom = defaultCustomHandler, _widgetPreferredSize = preferredSize, diff --git a/src/GUI/Widget/Sandbox.hs b/src/GUI/Widget/Sandbox.hs index 55e4f28a..8cb95d30 100644 --- a/src/GUI/Widget/Sandbox.hs +++ b/src/GUI/Widget/Sandbox.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} @@ -16,17 +17,24 @@ import GUI.Common.Style import GUI.Data.Tree import GUI.Widget.Core +import GHC.Generics + import qualified Data.Text as T data SandboxData = SandboxData | SandboxData2 deriving (Eq, Show, Typeable) +data SandboxState = SandboxState { + _clickCount :: Int +} deriving (Eq, Show, Typeable, Generic) sandbox :: (MonadState s m, MonadIO m) => e -> WidgetNode s e m -sandbox onClick = singleWidget (makeSandbox 0 onClick) +sandbox onClick = singleWidget (makeSandbox (SandboxState 0) onClick) -makeSandbox :: (MonadState s m, MonadIO m) => Int -> e -> Widget s e m +makeSandbox :: (MonadState s m, MonadIO m) => SandboxState -> e -> Widget s e m makeSandbox state onClick = Widget { _widgetType = "button", _widgetFocusable = False, + _widgetRestoreState = fmap (flip makeSandbox onClick) . useState, + _widgetSaveState = makeState state, _widgetHandleEvent = handleEvent, _widgetHandleCustom = handleCustom, _widgetPreferredSize = preferredSize, @@ -37,7 +45,7 @@ makeSandbox state onClick = Widget { handleEvent view evt = case evt of Click (Point x y) _ status -> resultReqsEventsWidget requests events (makeSandbox newState onClick) where isPressed = status == PressedBtn && inRect view (Point x y) - newState = if isPressed then state + 1 else state + newState = if isPressed then SandboxState (_clickCount state + 1) else state events = if isPressed then [onClick] else [] requests = if isPressed then [RunCustom runCustom] else [] _ -> Nothing @@ -46,9 +54,9 @@ makeSandbox state onClick = Widget { handleCustom bd = case cast bd of Just val -> if val == SandboxData2 then Nothing else Nothing Nothing -> Nothing - preferredSize renderer (style@Style{..}) _ = calcTextBounds renderer _textStyle (T.pack (show state)) + preferredSize renderer (style@Style{..}) _ = calcTextBounds renderer _textStyle (T.pack (show (_clickCount state))) resizeChildren _ _ _ = Nothing render renderer WidgetInstance{..} _ ts = do drawBgRect renderer _widgetInstanceRenderArea _widgetInstanceStyle - drawText renderer _widgetInstanceRenderArea (_textStyle _widgetInstanceStyle) (T.pack (show state)) + drawText renderer _widgetInstanceRenderArea (_textStyle _widgetInstanceStyle) (T.pack (show (_clickCount state))) diff --git a/src/GUI/Widget/Scroll.hs b/src/GUI/Widget/Scroll.hs index ceacde8e..7276cdbc 100644 --- a/src/GUI/Widget/Scroll.hs +++ b/src/GUI/Widget/Scroll.hs @@ -1,10 +1,12 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} module GUI.Widget.Scroll (scroll) where import Data.Default +import Data.Typeable import Control.Monad import Control.Monad.State @@ -16,11 +18,13 @@ import GUI.Common.Style import GUI.Data.Tree import GUI.Widget.Core +import GHC.Generics + data ScrollState = ScrollState { _scDeltaX :: !Double, _scDeltaY :: !Double, _scChildSize :: Size -} deriving (Eq, Show) +} deriving (Eq, Show, Typeable, Generic) scroll :: (MonadState s m) => WidgetNode s e m -> WidgetNode s e m scroll managedWidget = parentWidget (makeScroll (ScrollState 0 0 def)) [managedWidget] @@ -29,6 +33,8 @@ makeScroll :: (MonadState s m) => ScrollState -> Widget s e m makeScroll state@(ScrollState dx dy cs@(Size cw ch)) = Widget { _widgetType = "scroll", _widgetFocusable = False, + _widgetRestoreState = fmap makeScroll . useState, + _widgetSaveState = makeState state, _widgetHandleEvent = handleEvent, _widgetHandleCustom = defaultCustomHandler, _widgetPreferredSize = preferredSize, diff --git a/src/GUI/Widget/TextField.hs b/src/GUI/Widget/TextField.hs index 9380a611..ddc5d0a5 100644 --- a/src/GUI/Widget/TextField.hs +++ b/src/GUI/Widget/TextField.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,8 @@ import Control.Monad import Control.Monad.State import Data.Char +import Data.Dynamic +import Data.Typeable import Debug.Trace @@ -17,12 +20,14 @@ import GUI.Common.Style import GUI.Data.Tree import GUI.Widget.Core +import GHC.Generics + import qualified Data.Text as T data TextFieldState = TextFieldState { _tfText :: String, _tfPosition :: Int -} deriving (Eq, Show) +} deriving (Eq, Show, Typeable, Generic) textField :: (MonadState s m) => WidgetNode s e m textField = singleWidget $ makeTextField (TextFieldState "" 0) @@ -31,9 +36,11 @@ textField = singleWidget $ makeTextField (TextFieldState "" 0) Check caret logic in nanovg's demo: https://github.com/memononen/nanovg/blob/master/example/demo.c#L901 --} makeTextField :: (MonadState s m) => TextFieldState -> Widget s e m -makeTextField (TextFieldState txt tp) = Widget { +makeTextField tfs@(TextFieldState txt tp) = Widget { _widgetType = "textField", _widgetFocusable = True, + _widgetRestoreState = fmap makeTextField . useState, + _widgetSaveState = makeState tfs, _widgetHandleEvent = handleEvent, _widgetHandleCustom = defaultCustomHandler, _widgetPreferredSize = preferredSize,