Calculate/merge style and theme on init/merge

app/Main.hs

@@ -78,7 +78,7 @@ handleAppEvent model evt = case evt of
   _ -> []
 
 buildUI :: App -> WidgetInstance App AppEvent
-buildUI model = trace "Creating UI" widgetTree7 where
+buildUI model = trace "Creating UI" widgetTree where
   widgetTree7 = zstack [
       widgetTree6,
       hstack [

src/Monomer/Widgets/Button.hs

@@ -91,13 +91,13 @@ makeButton config state = widget where
     _ -> Nothing
 
   getSizeReq wenv inst = sizeReq where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     Size w h = getTextSize wenv style caption
     factor = 1
     sizeReq = (FlexSize w factor, FixedSize h)
 
   resize wenv viewport renderArea inst = newInst where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     size = getTextSize wenv style caption
     (newCaptionFit, _) = case textOverflow of
       Ellipsis -> fitText wenv style renderArea caption
@@ -114,5 +114,5 @@ makeButton config state = widget where
     drawStyledText_ renderer contentRect style captionFit
     resetScissor renderer
     where
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       contentRect = getContentRect style inst

src/Monomer/Widgets/Checkbox.hs

@@ -109,7 +109,7 @@ makeCheckbox widgetData config = widget where
       renderMark renderer config rarea fgColor
     where
       model = _weModel wenv
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       value = widgetDataGet model widgetData
       rarea = removeOuterBounds style $ _wiRenderArea inst
       checkboxL = _rX rarea

src/Monomer/Widgets/Composite.hs

@@ -247,7 +247,7 @@ compositeUpdateSizeReq
   -> WidgetInstance sp ep
 compositeUpdateSizeReq comp state wenv widgetComp = newComp where
   CompositeState{..} = state
-  style = instanceStyle wenv widgetComp
+  style = activeStyle wenv widgetComp
   widget = _wiWidget _cmpRoot
   cwenv = convertWidgetEnv wenv _cmpGlobalKeys _cmpModel
   newRoot = widgetUpdateSizeReq widget cwenv _cmpRoot
@@ -275,7 +275,7 @@ compositeResize
   -> WidgetInstance sp ep
 compositeResize comp state wenv viewport renderArea widgetComp = resized where
   CompositeState{..} = state
-  style = instanceStyle wenv widgetComp
+  style = activeStyle wenv widgetComp
   contentArea = removeOuterBounds style renderArea
   widget = _wiWidget _cmpRoot
   cwenv = convertWidgetEnv wenv _cmpGlobalKeys _cmpModel

src/Monomer/Widgets/Container.hs

@@ -96,6 +96,11 @@ type ContainerGetSizeReqHandler s e
   -> Seq (WidgetInstance s e)
   -> (SizeReq, SizeReq)
 
+type ContainerGetBaseStyle s e
+  = WidgetEnv s e
+  -> WidgetInstance s e
+  -> Maybe Style
+
 type ContainerResizeHandler s e
   = WidgetEnv s e
   -> Rect
@@ -114,6 +119,7 @@ data Container s e = Container {
   containerInit :: ContainerInitHandler s e,
   containerMerge :: ContainerMergeHandler s e,
   containerDispose :: ContainerDisposeHandler s e,
+  containerGetBaseStyle :: ContainerGetBaseStyle s e,
   containerGetState :: ContainerGetStateHandler s e,
   containerFindNextFocus :: ContainerFindNextFocusHandler s e,
   containerFindByPoint :: ContainerFindByPointHandler s e,
@@ -129,6 +135,7 @@ instance Default (Container s e) where
     containerInit = defaultInit,
     containerMerge = defaultMerge,
     containerDispose = defaultDispose,
+    containerGetBaseStyle = defaultGetBaseStyle,
     containerGetState = defaultGetState,
     containerFindNextFocus = defaultFindNextFocus,
     containerFindByPoint = defaultFindByPoint,
@@ -141,8 +148,8 @@ instance Default (Container s e) where
 
 createContainer :: Container s e -> Widget s e
 createContainer Container{..} = Widget {
-  widgetInit = initWrapper containerInit,
-  widgetMerge = mergeWrapper containerMerge,
+  widgetInit = initWrapper containerInit containerGetBaseStyle,
+  widgetMerge = mergeWrapper containerMerge containerGetBaseStyle,
   widgetDispose = disposeWrapper containerDispose,
   widgetGetState = containerGetState,
   widgetFindNextFocus = findNextFocusWrapper containerFindNextFocus,
@@ -181,10 +188,11 @@ defaultInit _ inst = resultWidget inst
 
 initWrapper
   :: ContainerInitHandler s e
+  -> ContainerGetBaseStyle s e
   -> WidgetEnv s e
   -> WidgetInstance s e
   -> WidgetResult s e
-initWrapper initHandler wenv inst = result where
+initWrapper initHandler getBaseStyle wenv inst = newResult where
   WidgetResult reqs events tempInstance = initHandler wenv inst
   children = _wiChildren tempInstance
   indexes = Seq.fromList [0..length children]
@@ -199,6 +207,8 @@ initWrapper initHandler wenv inst = result where
     _wiChildren = newChildren
   }
   result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance
+  baseStyle = getBaseStyle wenv newInstance
+  newResult = baseStyleToResult wenv baseStyle result
 
 -- | Merging
 defaultMerge :: ContainerMergeHandler s e
@@ -206,11 +216,12 @@ defaultMerge wenv state newInstance = resultWidget newInstance
 
 mergeWrapper
   :: ContainerMergeHandler s e
+  -> ContainerGetBaseStyle s e
   -> WidgetEnv s e
   -> WidgetInstance s e
   -> WidgetInstance s e
   -> WidgetResult s e
-mergeWrapper mergeHandler wenv oldInst newInst = result where
+mergeWrapper mergeHandler getBaseStyle wenv oldInst newInst = newResult where
   oldState = widgetGetState (_wiWidget oldInst) wenv
   tempInst = newInst {
     _wiViewport = _wiViewport oldInst,
@@ -235,6 +246,8 @@ mergeWrapper mergeHandler wenv oldInst newInst = result where
   newReqs = uReqs <> mergedReqs <> removedReqs
   newEvents = uEvents <> mergedEvents <> removedEvents
   result = WidgetResult newReqs newEvents mergedInstance
+  baseStyle = getBaseStyle wenv uInstance
+  newResult = baseStyleToResult wenv baseStyle result
 
 mergeChildren
   :: WidgetEnv s e
@@ -280,6 +293,10 @@ disposeWrapper disposeHandler wenv inst = result where
   newEvents = fold $ fmap _wrEvents results
   result = WidgetResult (reqs <> newReqs) (events <> newEvents) inst
 
+-- | Get base style for component
+defaultGetBaseStyle :: ContainerGetBaseStyle s e
+defaultGetBaseStyle wenv inst = Nothing
+
 -- | State Handling helpers
 defaultGetState :: ContainerGetStateHandler s e
 defaultGetState _ = Nothing
@@ -453,7 +470,7 @@ updateSizeReqWrapper
   -> WidgetInstance s e
   -> WidgetInstance s e
 updateSizeReqWrapper psHandler wenv inst = newInst where
-  style = instanceStyle wenv inst
+  style = activeStyle wenv inst
   children = _wiChildren inst
   updateChild child = widgetUpdateSizeReq (_wiWidget child) wenv child
   newChildren = fmap updateChild children
@@ -479,7 +496,7 @@ resizeWrapper
   -> WidgetInstance s e
   -> WidgetInstance s e
 resizeWrapper handler wenv viewport renderArea inst = newSize where
-  style = instanceStyle wenv inst
+  style = activeStyle wenv inst
   contentArea = removeOuterBounds style renderArea
   children = _wiChildren inst
   (tempInst, assigned) = handler wenv viewport contentArea children inst
@@ -514,7 +531,7 @@ renderWrapper rHandler renderer wenv inst =
       forM_ children $ \child -> when (isVisible child) $
         widgetRender (_wiWidget child) renderer wenv child
   where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     children = _wiChildren inst
     viewport = _wiViewport inst
     renderArea = _wiRenderArea inst

src/Monomer/Widgets/Dropdown.hs

@@ -288,7 +288,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
     result = WidgetResult (reqs <> newReqs) (events <> newEvents) newInstance
 
   getSizeReq wenv inst children = sizeReq where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     Size w h = getTextSize wenv style (dropdownLabel wenv)
     factor = 1
     sizeReq = (FlexSize w factor, FixedSize h)
@@ -325,7 +325,7 @@ makeDropdown widgetData items makeMain makeRow config state = widget where
     where
       listViewOverlay = Seq.lookup 0 _wiChildren
       renderArea = _wiRenderArea
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
 
   renderOverlay renderer wenv overlayInstance = renderAction where
     widget = _wiWidget overlayInstance

src/Monomer/Widgets/Image.hs

@@ -149,7 +149,7 @@ makeImage imgPath config state = widget where
     result = Just $ resultReqs [Resize] newInst
 
   getSizeReq wenv inst = sizeReq where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     Size w h = maybe def snd (isImageData state)
     factor = 1
     sizeReq = (FlexSize w factor, FlexSize h factor)
@@ -162,7 +162,7 @@ makeImage imgPath config state = widget where
       drawInScissor renderer True contentRect $
         drawImage renderer imgPath imageRect alpha
     where
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       contentRect = getContentRect style inst
       alpha = fromMaybe 1 (_imcTransparency config)
       fitMode = fromMaybe FitNone (_imcFit config)

src/Monomer/Widgets/InputField.hs

@@ -183,7 +183,7 @@ makeInputField config state = widget where
 
   handleEvent wenv target evt inst = case evt of
     Click (Point x y) _ -> result where
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       rect = getContentRect style inst
       localX = x - _rX rect + _ifsOffset state
       textLen = getGlyphsMax (_ifsGlyphs state)
@@ -279,7 +279,7 @@ makeInputField config state = widget where
       end = max currPos (fromJust currSel)
 
   getSizeReq wenv inst = sizeReq where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     Size w h = getTextSize wenv style currText
     factor = 1
     sizeReq = (FlexSize w factor, FixedSize h)
@@ -308,7 +308,7 @@ makeInputField config state = widget where
 
     resetScissor renderer
     where
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       contentRect = getContentRect style inst
       Rect cx cy cw ch = contentRect
       textMetrics = _ifsTextMetrics state
@@ -358,7 +358,7 @@ newTextState
   -> Maybe Int
   -> InputFieldState a
 newTextState wenv inst oldState value text cursor selection = newState where
-  style = instanceStyle wenv inst
+  style = activeStyle wenv inst
   contentRect = getContentRect style inst
   !(Rect cx cy cw ch) = contentRect
   !textMetrics = getTextMetrics wenv style contentRect align text

src/Monomer/Widgets/Label.hs

@@ -69,13 +69,13 @@ makeLabel config state = widget where
     }
 
   getSizeReq wenv inst = sizeReq where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     Size w h = getTextSize wenv style caption
     factor = 1
     sizeReq = (FlexSize w factor, FixedSize h)
 
   resize wenv viewport renderArea inst = newInst where
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst
     (newCaptionFit, _) = case textOverflow of
       Ellipsis -> fitText wenv style renderArea caption
       _ -> (caption, def)
@@ -90,5 +90,5 @@ makeLabel config state = widget where
     drawInScissor renderer True contentRect $
       drawStyledText_ renderer contentRect style captionFit
     where
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       contentRect = getContentRect style inst

src/Monomer/Widgets/Radio.hs

@@ -114,7 +114,7 @@ makeRadio field option config = widget where
       renderMark renderer config rarea fgColor
     where
       model = _weModel wenv
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       value = widgetDataGet model field
       rarea = removeOuterBounds style $ _wiRenderArea inst
       radioL = _rX rarea

src/Monomer/Widgets/Single.hs

@@ -36,6 +36,11 @@ type SingleDisposeHandler s e
   -> WidgetInstance s e
   -> WidgetResult s e
 
+type SingleGetBaseStyle s e
+  = WidgetEnv s e
+  -> WidgetInstance s e
+  -> Maybe Style
+
 type SingleGetStateHandler s e
   = WidgetEnv s e
   -> Maybe WidgetState
@@ -91,6 +96,7 @@ data Single s e = Single {
   singleInit :: SingleInitHandler s e,
   singleMerge :: SingleMergeHandler s e,
   singleDispose :: SingleDisposeHandler s e,
+  singleGetBaseStyle :: SingleGetBaseStyle s e,
   singleGetState :: SingleGetStateHandler s e,
   singleFindNextFocus :: SingleFindNextFocusHandler s e,
   singleFindByPoint :: SingleFindByPointHandler s e,
@@ -106,6 +112,7 @@ instance Default (Single s e) where
     singleInit = defaultInit,
     singleMerge = defaultMerge,
     singleDispose = defaultDispose,
+    singleGetBaseStyle = defaultGetBaseStyle,
     singleGetState = defaultGetState,
     singleFindNextFocus = defaultFindNextFocus,
     singleFindByPoint = defaultFindByPoint,
@@ -118,8 +125,8 @@ instance Default (Single s e) where
 
 createSingle :: Single s e -> Widget s e
 createSingle Single{..} = Widget {
-  widgetInit = singleInit,
-  widgetMerge = mergeWrapper singleMerge,
+  widgetInit = initWrapper singleInit singleGetBaseStyle,
+  widgetMerge = mergeWrapper singleMerge singleGetBaseStyle,
   widgetDispose = singleDispose,
   widgetGetState = singleGetState,
   widgetFindNextFocus = singleFindNextFocus,
@@ -134,28 +141,45 @@ createSingle Single{..} = Widget {
 defaultInit :: SingleInitHandler s e
 defaultInit _ inst = resultWidget inst
 
+initWrapper
+  :: SingleInitHandler s e
+  -> SingleGetBaseStyle s e
+  -> WidgetEnv s e
+  -> WidgetInstance s e
+  -> WidgetResult s e
+initWrapper initHandler getBaseStyle wenv inst = newResult where
+  baseStyle = getBaseStyle wenv inst
+  tempResult = initHandler wenv inst
+  newResult = baseStyleToResult wenv baseStyle tempResult
+
 defaultMerge :: SingleMergeHandler s e
 defaultMerge wenv oldState newInst = resultWidget newInst
 
-defaultDispose :: SingleDisposeHandler s e
-defaultDispose _ inst = resultWidget inst
-
-defaultGetState :: SingleGetStateHandler s e
-defaultGetState _ = Nothing
-
 mergeWrapper
   :: SingleMergeHandler s e
+  -> SingleGetBaseStyle s e
   -> WidgetEnv s e
   -> WidgetInstance s e
   -> WidgetInstance s e
   -> WidgetResult s e
-mergeWrapper mergeHandler wenv oldInst newInst = result where
+mergeWrapper mergeHandler getBaseStyle wenv oldInst newInst = newResult where
   oldState = widgetGetState (_wiWidget oldInst) wenv
   tempInst = newInst {
     _wiViewport = _wiViewport oldInst,
     _wiRenderArea = _wiRenderArea oldInst
   }
-  result = mergeHandler wenv oldState tempInst
+  baseStyle = getBaseStyle wenv tempInst
+  tempResult = mergeHandler wenv oldState tempInst
+  newResult = baseStyleToResult wenv baseStyle tempResult
+
+defaultDispose :: SingleDisposeHandler s e
+defaultDispose _ inst = resultWidget inst
+
+defaultGetBaseStyle :: SingleGetBaseStyle s e
+defaultGetBaseStyle wenv inst = Nothing
+
+defaultGetState :: SingleGetStateHandler s e
+defaultGetState _ = Nothing
 
 defaultFindNextFocus :: SingleFindNextFocusHandler s e
 defaultFindNextFocus wenv direction startFrom inst
@@ -193,7 +217,7 @@ updateSizeReqWrapper
   -> WidgetInstance s e
   -> WidgetInstance s e
 updateSizeReqWrapper handler wenv inst = newInst where
-  style = instanceStyle wenv inst
+  style = activeStyle wenv inst
   reqs = handler wenv inst
   (newReqW, newReqH) = handleSizeReqStyle style reqs
   newInst = inst {
@@ -218,4 +242,4 @@ renderWrapper rHandler renderer wenv inst =
     rHandler renderer wenv inst
   where
     renderArea = _wiRenderArea inst
-    style = instanceStyle wenv inst
+    style = activeStyle wenv inst

src/Monomer/Widgets/Util/Base.hs

@@ -1,4 +1,5 @@
 module Monomer.Widgets.Util.Base (
+  baseStyleToResult,
   handleSizeReqStyle,
   handleStyleChange,
   isFixedSizeReq,
@@ -6,8 +7,7 @@ module Monomer.Widgets.Util.Base (
   isBoundedSizeReq,
   getMinSizeReq,
   getMaxSizeReq,
-  getFactorReq,
-  modifySizeReq
+  getFactorReq
 ) where
 
 import Data.Default
@@ -28,6 +28,43 @@ type EventHandler s e
   -> WidgetInstance s e
   -> Maybe (WidgetResult s e)
 
+baseStyleFromTheme :: Theme -> Style
+baseStyleFromTheme theme = style where
+  style = Style {
+    _styleBasic = fromThemeState (_themeBasic theme),
+    _styleHover = fromThemeState (_themeHover theme),
+    _styleFocus = fromThemeState (_themeFocus theme),
+    _styleDisabled = fromThemeState (_themeDisabled theme)
+  }
+  fromThemeState tstate = Just $ def {
+    _sstFgColor = Just $ _thsFgColor tstate,
+    _sstHlColor = Just $ _thsHlColor tstate,
+    _sstText = Just $ _thsText tstate
+  }
+
+baseStyleToResult
+  :: WidgetEnv s e
+  -> Maybe Style
+  -> WidgetResult s e
+  -> WidgetResult s e
+baseStyleToResult wenv mbaseStyle result = newResult where
+  baseStyle = fromMaybe def mbaseStyle
+  themeStyle = baseStyleFromTheme (_weTheme wenv)
+  WidgetResult reqs evts inst = result
+  newInst = inst {
+    _wiStyle = mergeBasicStyle (themeStyle <> baseStyle <> _wiStyle inst)
+  }
+  newResult = WidgetResult reqs evts newInst
+
+mergeBasicStyle :: Style -> Style
+mergeBasicStyle st = newStyle where
+  newStyle = Style {
+    _styleBasic = _styleBasic st,
+    _styleHover = _styleBasic st <> _styleHover st,
+    _styleFocus = _styleBasic st <> _styleFocus st,
+    _styleDisabled = _styleBasic st <> _styleDisabled st
+  }
+
 handleStyleChange
   :: EventHandler s e
   -> WidgetEnv s e
@@ -36,7 +73,7 @@ handleStyleChange
   -> WidgetInstance s e
   -> Maybe (WidgetResult s e)
 handleStyleChange handler wenv target evt inst = newResult where
-  style = instanceStyle wenv inst
+  style = activeStyle wenv inst
   hResult
     | _wiEnabled inst = handler wenv target evt inst
     | otherwise = Nothing

src/Monomer/Widgets/Util/Style.hs

@@ -1,12 +1,9 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module Monomer.Widgets.Util.Style (
   getContentRect,
   activeStyle,
-  activeTheme,
-  instanceStyle,
-  mergeThemeStyle
+  activeTheme
 ) where
 
 import Control.Applicative ((<|>))
@@ -30,10 +27,10 @@ activeStyle wenv inst = fromMaybe def styleState where
   isHover = pointInViewport mousePos inst
   isFocus = isFocused wenv inst
   styleState
-    | not isEnabled = _styleBasic <> _styleDisabled
-    | isHover && isFocus = _styleBasic <> _styleFocus <> _styleHover
-    | isHover = _styleBasic <> _styleHover
-    | isFocus = _styleBasic <> _styleFocus
+    | not isEnabled = _styleDisabled
+    | isHover && isFocus = _styleFocus <> _styleHover
+    | isHover = _styleHover
+    | isFocus = _styleFocus
     | otherwise = _styleBasic
 
 activeTheme :: WidgetEnv s e -> WidgetInstance s e -> ThemeState
@@ -48,19 +45,3 @@ activeTheme wenv inst = themeState where
     | isHover = _themeHover theme
     | isFocus = _themeFocus theme
     | otherwise = _themeBasic theme
-
-instanceStyle :: WidgetEnv s e -> WidgetInstance s e -> StyleState
-instanceStyle wenv inst = mergeThemeStyle theme style where
-  style = activeStyle wenv inst
-  theme = activeTheme wenv inst
-
-mergeThemeStyle :: ThemeState -> StyleState -> StyleState
-mergeThemeStyle theme style = newStyle where
-  themeFgColor = Just $ _thsFgColor theme
-  themeHlColor = Just $ _thsHlColor theme
-  themeTextNormal = Just $ _thsText theme
-  !newStyle = style {
-    _sstFgColor = _sstFgColor style <|> themeFgColor,
-    _sstHlColor = _sstHlColor style <|> themeHlColor,
-    _sstText = themeTextNormal <> _sstText style
-  }

src/Monomer/Widgets/ZStack.hs

@@ -106,7 +106,7 @@ makeZStack config = widget where
         forM_ children $ \child -> when (isVisible child) $
           widgetRender (_wiWidget child) renderer wenv child
     where
-      style = instanceStyle wenv inst
+      style = activeStyle wenv inst
       children = Seq.reverse $ _wiChildren inst
       viewport = _wiViewport inst
       renderArea = _wiRenderArea inst

tasks.md

@@ -235,9 +235,9 @@
   - Make sure that focus change requests do not leave overlay if active (most likely an if clause is needed in handleFocusChange)
   - Return list of actions instead of Monoid in eventHandler
   - Add way of requesting findNextFocus (needed on Dropdown)
+  - Add way of ignoring unassigned events in stack (or return nothing from findByPoint)
 
 - Pending
-  - Add way of ignoring unassigned events in stack (or return nothing from findByPoint)
   - Use theme for all components
   - Multiline label
   - Add testing
@@ -256,6 +256,7 @@
 Maybe postponed after release?
   - Update style when merging to avoid recalculating/merging theme every time
   - Handle onBlur/onFocus in all focusable widgets
+  - Maybe unify criteria on zstack? Top layer config for both focus/click?
   - Avoid findNextFocus on unfocusable children (listView items)
   - Restore focus to previous widget when zstack changes (dialog situation)
     - Also think about not losing focus because of click (when onlyTopFocusable is active)