Add state save/restore handling

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,

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)

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,

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,

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)))

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,

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,