Fix space leak when rebuilding UI and handling events (#19)

* Basic tests with Strict/StrictData. These will be progressively replaced by strict fields/bang patterns, and also squashed before merging.

* Change pragmas, reduce Strict, replace with StrictData/BangPatterns in containers. Reduce space leaks

* Format package.yaml

* Remove unneeded bangs, restore tutorial main

* Bump version and update Changelog

ChangeLog.md

@@ -1,11 +1,13 @@
 ### 1.0.0.3
 
 - Consume and forward all available messages from Producers on each cycle.
+- Add Nix and GitHub Actions support (thanks @smunix!).
+- Fix space leak when rebuilding the UI or handling events.
 
 ### 1.0.0.2
 
 - Use the recently published nanovg-0.8.0.0 from Hackage, instead of the version from the PR's commit.
-- Added `appRenderOnMainThread` option.
+- Add `appRenderOnMainThread` option.
 
 ### 1.0.0.1
 

monomer.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           monomer
-version:        1.0.0.2
+version:        1.0.0.3
 synopsis:       A GUI library for writing native Haskell applications.
 description:    Monomer is an easy to use, cross platform, GUI library for writing native
                 Haskell applications.

package.yaml

@@ -1,5 +1,5 @@
 name: monomer
-version: 1.0.0.2
+version: 1.0.0.3
 github: fjvallarino/monomer
 license: BSD3
 author: Francisco Vallarino
@@ -7,8 +7,8 @@ maintainer: fjvallarino@gmail.com
 copyright: 2018 Francisco Vallarino
 
 extra-source-files:
-- README.md
-- ChangeLog.md
+  - README.md
+  - ChangeLog.md
 
 # Metadata used when publishing your package
 synopsis: A GUI library for writing native Haskell applications.
@@ -23,51 +23,51 @@ description: |
   Please see the README on Github at <https://github.com/fjvallarino/monomer#readme>
 
 default-extensions:
-- OverloadedStrings
+  - OverloadedStrings
 
 dependencies:
-- async >= 2.1 && < 2.3
-- attoparsec >= 0.12 && < 0.15
-- base >= 4.11 && < 5
-- bytestring >= 0.10 && < 0.12
-- bytestring-to-vector >= 0.3 && < 0.4
-- containers >= 0.5.11 && < 0.7
-- data-default >= 0.5 && < 0.8
-- exceptions >= 0.10 && < 0.11
-- extra >= 1.6 && < 1.9
-- formatting >= 6.0 && < 8.0
-- http-client >= 0.6 && < 0.9
-- JuicyPixels >= 3.2.9 && < 3.5
-- lens >= 4.16 && < 5.1
-- mtl >= 2.1 && < 2.3
-- nanovg >= 0.8 && < 1.0
-- OpenGL >= 3.0 && < 3.1
-- process >= 1.6 && < 1.7
-- safe >= 0.3 && < 0.4
-- sdl2 >= 2.4.0 && < 2.6
-- stm >= 2.5 && < 2.6
-- text >= 1.2 && < 1.3
-- text-show >= 3.7 && < 3.10
-- time >= 1.8 && < 1.13
-- transformers >= 0.5 && < 0.7
-- unordered-containers >= 0.2.8 && < 0.3
-- vector >= 0.12 && < 0.14
-- wreq >= 0.5.2 && < 0.6
+  - async >= 2.1 && < 2.3
+  - attoparsec >= 0.12 && < 0.15
+  - base >= 4.11 && < 5
+  - bytestring >= 0.10 && < 0.12
+  - bytestring-to-vector >= 0.3 && < 0.4
+  - containers >= 0.5.11 && < 0.7
+  - data-default >= 0.5 && < 0.8
+  - exceptions >= 0.10 && < 0.11
+  - extra >= 1.6 && < 1.9
+  - formatting >= 6.0 && < 8.0
+  - http-client >= 0.6 && < 0.9
+  - JuicyPixels >= 3.2.9 && < 3.5
+  - lens >= 4.16 && < 5.1
+  - mtl >= 2.1 && < 2.3
+  - nanovg >= 0.8 && < 1.0
+  - OpenGL >= 3.0 && < 3.1
+  - process >= 1.6 && < 1.7
+  - safe >= 0.3 && < 0.4
+  - sdl2 >= 2.4.0 && < 2.6
+  - stm >= 2.5 && < 2.6
+  - text >= 1.2 && < 1.3
+  - text-show >= 3.7 && < 3.10
+  - time >= 1.8 && < 1.13
+  - transformers >= 0.5 && < 0.7
+  - unordered-containers >= 0.2.8 && < 0.3
+  - vector >= 0.12 && < 0.14
+  - wreq >= 0.5.2 && < 0.6
 
 library:
   source-dirs: src
   include-dirs: cbits
   install-includes:
-  - fontmanager.h
+    - fontmanager.h
   c-sources:
-  - cbits/dpi.c
-  - cbits/fontmanager.c
-  - cbits/glew.c
+    - cbits/dpi.c
+    - cbits/fontmanager.c
+    - cbits/glew.c
   build-tools: c2hs
   cc-options:
-  - -fPIC
+    - -fPIC
   ghc-options:
-  - -fwarn-incomplete-patterns
+    - -fwarn-incomplete-patterns
   when:
     - condition: os(windows)
       then:
@@ -80,71 +80,71 @@ executables:
     main: Main.hs
     source-dirs: examples/todo
     ghc-options:
-    - -threaded
+      - -threaded
     dependencies:
-    - lens >= 4.16 && < 5.1
-    - monomer
-    - text-show >= 3.7 && < 3.10
+      - lens >= 4.16 && < 5.1
+      - monomer
+      - text-show >= 3.7 && < 3.10
 
   books:
     main: Main.hs
     source-dirs: examples/books
     ghc-options:
-    - -threaded
+      - -threaded
     dependencies:
-    - aeson >= 1.4 && < 1.6
-    - lens >= 4.16 && < 5.1
-    - monomer
-    - text-show >= 3.7 && < 3.10
-    - wreq >= 0.5.2 && < 0.6
+      - aeson >= 1.4 && < 1.6
+      - lens >= 4.16 && < 5.1
+      - monomer
+      - text-show >= 3.7 && < 3.10
+      - wreq >= 0.5.2 && < 0.6
 
   ticker:
     main: Main.hs
     source-dirs: examples/ticker
     ghc-options:
-    - -threaded
+      - -threaded
     dependencies:
-    - aeson >= 1.4 && < 1.6
-    - lens >= 4.16 && < 5.1
-    - monomer
-    - scientific >= 0.3 && < 0.4
-    - text-show >= 3.7 && < 3.10
-    - websockets >= 0.12 && < 0.13
-    - wuss >= 1.1 && < 1.2
+      - aeson >= 1.4 && < 1.6
+      - lens >= 4.16 && < 5.1
+      - monomer
+      - scientific >= 0.3 && < 0.4
+      - text-show >= 3.7 && < 3.10
+      - websockets >= 0.12 && < 0.13
+      - wuss >= 1.1 && < 1.2
 
   generative:
     main: Main.hs
     source-dirs: examples/generative
     ghc-options:
-    - -threaded
+      - -threaded
     dependencies:
-    - lens >= 4.16 && < 5.1
-    - monomer
-    - random >= 1.1 && < 1.3
-    - text-show >= 3.7 && < 3.10
+      - lens >= 4.16 && < 5.1
+      - monomer
+      - random >= 1.1 && < 1.3
+      - text-show >= 3.7 && < 3.10
 
   tutorial:
     main: Main.hs
     source-dirs: examples/tutorial
     ghc-options:
-    - -threaded
+      - -threaded
     dependencies:
-    - lens >= 4.16 && < 5.1
-    - monomer
-    - random >= 1.1 && < 1.3
-    - text-show >= 3.7 && < 3.10
-    - time >= 1.8 && < 1.13
+      - lens >= 4.16 && < 5.1
+      - monomer
+      - random >= 1.1 && < 1.3
+      - text-show >= 3.7 && < 3.10
+      - time >= 1.8 && < 1.13
 
 tests:
   monomer-test:
     main: Spec.hs
     source-dirs: test/unit
     ghc-options:
-    - -threaded
-    - -fwarn-incomplete-patterns
+      - -threaded
+      - -fwarn-incomplete-patterns
     dependencies:
-    - directory >= 1.3 && < 1.4
-    - monomer
-    - hspec >= 2.4 && < 3.0
-    - HUnit >= 1.6 && < 1.7
-    - silently >= 1.2 && < 1.3
+      - directory >= 1.3 && < 1.4
+      - monomer
+      - hspec >= 2.4 && < 3.0
+      - HUnit >= 1.6 && < 1.7
+      - silently >= 1.2 && < 1.3

src/Monomer/Core/SizeReq.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Helper functions creating, validating and merging size requirements.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Core.SizeReq (
   SizeReqUpdater(..),
   clearExtra,

src/Monomer/Core/Style.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Helper functions for creating style configurations, and corresponding instances.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Core.Style (
   module Monomer.Core.StyleTypes,
   module Monomer.Core.ThemeTypes,

src/Monomer/Core/StyleTypes.hs

@@ -9,6 +9,7 @@ Portability : non-portable
 Basic types for styling widgets.
 -}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Core.StyleTypes where
 

src/Monomer/Core/StyleUtil.hs

@@ -10,6 +10,7 @@ Helper functions for style types.
 -}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Core.StyleUtil (
   getContentArea,

src/Monomer/Core/ThemeTypes.hs

@@ -9,6 +9,7 @@ Portability : non-portable
 Theme configuration types.
 -}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Core.ThemeTypes where
 

src/Monomer/Core/WidgetTypes.hs

@@ -12,6 +12,7 @@ Basic types and definitions for Widgets.
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Core.WidgetTypes where
 
@@ -342,29 +343,29 @@ data WidgetEnv s e = WidgetEnv {
 data WidgetNodeInfo =
   WidgetNodeInfo {
     -- | Type of the widget.
-    _wniWidgetType :: !WidgetType,
+    _wniWidgetType :: WidgetType,
     -- | The identifier at creation time of the widget (runtime generated).
-    _wniWidgetId :: !WidgetId,
+    _wniWidgetId :: WidgetId,
     -- | Key/Identifier of the widget (user provided). Used for merging.
     _wniKey :: Maybe WidgetKey,
     -- | The path of the instance in the widget tree, as a set of indexes.
-    _wniPath :: !Path,
+    _wniPath :: Path,
     -- | The requested width for the widget. The one in style takes precedence.
-    _wniSizeReqW :: !SizeReq,
+    _wniSizeReqW :: SizeReq,
     -- | The requested height for the widget. The one in style takes precedence.
-    _wniSizeReqH :: !SizeReq,
+    _wniSizeReqH :: SizeReq,
     -- | Indicates if the widget is enabled for user interaction.
-    _wniEnabled :: !Bool,
+    _wniEnabled :: Bool,
     -- | Indicates if the widget is visible.
-    _wniVisible :: !Bool,
+    _wniVisible :: Bool,
     -- | Indicates whether the widget can receive focus.
-    _wniFocusable :: !Bool,
+    _wniFocusable :: Bool,
     {-|
     The area of the window where the widget can draw. Could be out of bounds or
     partially invisible if inside a scroll. The viewport on 'WidgetEnv' defines
     what is currently visible.
     -}
-    _wniViewport :: !Rect,
+    _wniViewport :: Rect,
     -- | Style attributes of the widget instance.
     _wniStyle :: Style
   } deriving (Eq, Show, Generic)

src/Monomer/Graphics/FontManager.hs

@@ -9,6 +9,7 @@ Portability : non-portable
 Provides functions for getting text dimensions and metrics.
 -}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Graphics.FontManager (
   makeFontManager

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -11,6 +11,7 @@ Renderer based on the nanovg library.
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TupleSections #-}
 
 module Monomer.Graphics.NanoVGRenderer (makeRenderer) where

src/Monomer/Graphics/Text.hs

@@ -11,6 +11,7 @@ Helper functions for calculating text size.
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Graphics.Text (
   calcTextSize,
@@ -193,7 +194,7 @@ getTextLinesSize textLines = size where
   spaceV = unFontSpace $ maybe def _tlFontSpaceV (textLines ^? ix 0)
   lineW line = line ^. L.size . L.w
   lineH line = line ^. L.size . L.h + unFontSpace (_tlFontSpaceV line)
-  width = maximum (fmap lineW textLines)
+  ~width = maximum (fmap lineW textLines)
   height = sum (fmap lineH textLines) - spaceV
   size
     | Seq.null textLines = def

src/Monomer/Graphics/Types.hs

@@ -11,6 +11,7 @@ Basic types for Graphics.
 Angles are always expressed in degrees, not radians.
 -}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Graphics.Types where
 

src/Monomer/Graphics/Util.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Helper functions for graphics related operations.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Graphics.Util (
   clampChannel,
   clampAlpha,
@@ -59,14 +61,17 @@ rgba r g b a = Color {
 -- | Creates a Color from a hex string. It may include a # prefix or not.
 rgbHex :: String -> Color
 rgbHex hex
-  | length hex == 7 = rgbHex (tail hex)
-  | length hex == 6 = rgb r g b
+  | length hex == 7 = rgbHexSix (tail hex)
+  | length hex == 6 = rgbHexSix hex
   | otherwise = rgb 0 0 0
-  where
-    [r1, r2, g1, g2, b1, b2] = hex
-    r = digitToInt r1 * 16 + digitToInt r2
-    g = digitToInt g1 * 16 + digitToInt g2
-    b = digitToInt b1 * 16 + digitToInt b2
+
+-- | Creates a color from a six characters hex string. Fails if len is invalid.
+rgbHexSix :: [Char] -> Color
+rgbHexSix hex = rgb r g b where
+  [r1, r2, g1, g2, b1, b2] = hex
+  r = digitToInt r1 * 16 + digitToInt r2
+  g = digitToInt g1 * 16 + digitToInt g2
+  b = digitToInt b1 * 16 + digitToInt b2
 
 {-|
 Creates a Color from a hex string plus an alpha component. It may include a #

src/Monomer/Main/Core.hs

@@ -8,9 +8,9 @@ Portability : non-portable
 
 Core glue for running an application.
 -}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Main.Core (
   AppEventResponse(..),
@@ -143,7 +143,7 @@ runAppLoop window glCtx channel widgetRoot config = do
 
   startTs <- fmap fromIntegral SDL.ticks
   model <- use L.mainModel
-  os <- getPlatform
+  os <- liftIO getPlatform
   widgetSharedMVar <- liftIO $ newMVar Map.empty
   renderer <- if useRenderThread
     then return Nothing
@@ -231,8 +231,8 @@ mainLoop window fontManager config loopArgs = do
   dragged <- getDraggedMsgInfo
   mainPress <- use L.mainBtnPress
   inputStatus <- use L.inputStatus
-  mousePos <- getCurrentMousePos epr
-  currWinSize <- getViewportSize window dpr
+  mousePos <- liftIO $ getCurrentMousePos epr
+  currWinSize <- liftIO $ getViewportSize window dpr
 
   let Size rw rh = windowSize
   let ts = startTicks - _mlFrameStartTs
@@ -419,29 +419,29 @@ renderWidgets
   -> WidgetEnv s e
   -> WidgetNode s e
   -> IO ()
-renderWidgets !window dpr renderer clearColor wenv widgetRoot = do
+renderWidgets window dpr renderer clearColor wenv widgetRoot = do
   Size dwW dwH <- getDrawableSize window
   Size vpW vpH <- getViewportSize window dpr
 
   let position = GL.Position 0 0
   let size = GL.Size (round dwW) (round dwH)
 
-  liftIO $ GL.viewport GL.$= (position, size)
+  GL.viewport GL.$= (position, size)
 
-  liftIO $ GL.clearColor GL.$= clearColor4
-  liftIO $ GL.clear [GL.ColorBuffer]
+  GL.clearColor GL.$= clearColor4
+  GL.clear [GL.ColorBuffer]
 
-  liftIO $ beginFrame renderer vpW vpH
-  liftIO $ widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer
-  liftIO $ endFrame renderer
+  beginFrame renderer vpW vpH
+  widgetRender (widgetRoot ^. L.widget) wenv widgetRoot renderer
+  endFrame renderer
 
-  liftIO $ renderRawTasks renderer
+  renderRawTasks renderer
 
-  liftIO $ beginFrame renderer vpW vpH
-  liftIO $ renderOverlays renderer
-  liftIO $ endFrame renderer
+  beginFrame renderer vpW vpH
+  renderOverlays renderer
+  endFrame renderer
 
-  liftIO $ renderRawOverlays renderer
+  renderRawOverlays renderer
 
   SDL.glSwapWindow window
   where

src/Monomer/Main/Handlers.hs

@@ -12,6 +12,7 @@ overlays and all SystemEvent related operations and updates.
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Main.Handlers (
   HandlerStep,

src/Monomer/Main/Platform.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Helper functions for SDL platform related operations.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Main.Platform (
   defaultWindowSize,
   initSDLWindow,
@@ -138,20 +140,20 @@ detroySDLWindow window = do
   SDL.quit
 
 -- | Returns the current mouse position.
-getCurrentMousePos :: (MonadIO m) => Double -> m Point
+getCurrentMousePos :: Double -> IO Point
 getCurrentMousePos epr = do
   SDL.P (SDL.V2 x y) <- Mouse.getAbsoluteMouseLocation
   return $ Point (epr * fromIntegral x) (epr * fromIntegral y)
 
 -- | Returns the drawable size of the provided window. May differ from window
 --   size if HDPI is enabled.
-getDrawableSize :: (MonadIO m) => SDL.Window -> m Size
+getDrawableSize :: SDL.Window -> IO Size
 getDrawableSize window = do
   SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window
   return $ Size (fromIntegral fbWidth) (fromIntegral fbHeight)
 
 -- | Returns the size of the provided window.
-getWindowSize :: (MonadIO m) => SDL.Window -> m Size
+getWindowSize :: SDL.Window -> IO Size
 getWindowSize window = do
   SDL.V2 rw rh <- SDL.get (SDL.windowSize window)
 
@@ -163,16 +165,16 @@ render to and, depending on the platform, may match window size or not. For
 example, on Windows and Linux Wayland this size may be smaller than the window
 size because of dpr scaling.
 -}
-getViewportSize :: (MonadIO m) => SDL.Window -> Double -> m Size
+getViewportSize :: SDL.Window -> Double -> IO Size
 getViewportSize window dpr = do
   SDL.V2 fw fh <- SDL.glGetDrawableSize window
 
   return $ Size (fromIntegral fw / dpr) (fromIntegral fh / dpr)
 
 -- | Returns the name of the host OS.
-getPlatform :: (MonadIO m) => m Text
+getPlatform :: IO Text
 getPlatform = do
-  platform <- liftIO . peekCString =<< Raw.getPlatform
+  platform <- peekCString =<< Raw.getPlatform
 
   return $ T.pack platform
 

src/Monomer/Main/Types.hs

@@ -14,6 +14,7 @@ Basic types for Main module.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Main.Types where
 
@@ -85,7 +86,7 @@ data MonomerCtx s e = MonomerCtx {
   -- | Main application model.
   _mcMainModel :: s,
   -- | Active window.
-  _mcWindow :: SDL.Window,
+  _mcWindow :: ~SDL.Window,
   -- | Main window size.
   _mcWindowSize :: Size,
   -- | Device pixel rate.

src/Monomer/Main/UserUtil.hs

@@ -9,6 +9,8 @@ Portability : non-portable
 Helper functions for Monomer users, to simplify common operations such as focus
 change and clipboard requests.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Main.UserUtil where
 
 import Control.Applicative ((<|>))

src/Monomer/Main/Util.hs

@@ -10,6 +10,7 @@ Helper functions for the Main module.
 -}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Main.Util where
 
@@ -45,7 +46,7 @@ initMonomerCtx
   -> Double
   -> s
   -> MonomerCtx s e
-initMonomerCtx win channel winSize dpr epr model = MonomerCtx {
+initMonomerCtx ~win channel winSize dpr epr model = MonomerCtx {
   _mcMainModel = model,
   _mcWindow = win,
   _mcWindowSize = winSize,

src/Monomer/Main/WidgetTask.hs

@@ -10,6 +10,7 @@ Handles the lifecycle and reporting of generated events of WidgetTasks (single
 message) and Producers (multiple messages).
 -}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Main.WidgetTask (handleWidgetTasks) where
 

src/Monomer/Widgets/Animation/Fade.hs

@@ -17,6 +17,7 @@ Messages:
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Animation.Fade (
   -- * Configuration

src/Monomer/Widgets/Animation/Slide.hs

@@ -16,6 +16,7 @@ Messages:
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Animation.Slide (
   -- * Configuration

src/Monomer/Widgets/Composite.hs

@@ -19,6 +19,7 @@ containers and singles.
 - Event Handler: processes user defined events which are raised by the widgets
 created when building the UI.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -266,9 +267,9 @@ compositeMergeReqs fn = def {
 }
 
 data Composite s e sp ep = Composite {
-  _cmpWidgetData :: WidgetData sp s,
-  _cmpEventHandler :: EventHandler s e sp ep,
-  _cmpUiBuilder :: UIBuilder s e,
+  _cmpWidgetData :: !(WidgetData sp s),
+  _cmpEventHandler :: !(EventHandler s e sp ep),
+  _cmpUiBuilder :: !(UIBuilder s e),
   _cmpMergeRequired :: MergeRequired s,
   _cmpMergeReqs :: [MergeReqsHandler s e],
   _cmpOnInit :: [e],
@@ -280,8 +281,8 @@ data Composite s e sp ep = Composite {
 }
 
 data CompositeState s e = CompositeState {
-  _cpsModel :: Maybe s,
-  _cpsRoot :: WidgetNode s e,
+  _cpsModel :: !(Maybe s),
+  _cpsRoot :: !(WidgetNode s e),
   _cpsWidgetKeyMap :: WidgetKeyMap s e
 }
 
@@ -366,7 +367,7 @@ compositeD_
 compositeD_ wType wData uiBuilder evtHandler configs = newNode where
   config = mconcat configs
   mergeReq = fromMaybe (/=) (_cmcMergeRequired config)
-  widgetRoot = spacer
+  !widgetRoot = spacer
   composite = Composite {
     _cmpWidgetData = wData,
     _cmpEventHandler = evtHandler,
@@ -382,14 +383,14 @@ compositeD_ wType wData uiBuilder evtHandler configs = newNode where
   }
   state = CompositeState Nothing widgetRoot M.empty
   widget = createComposite composite state
-  newNode = defaultWidgetNode wType widget
+  !newNode = defaultWidgetNode wType widget
 
 createComposite
   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
   => Composite s e sp ep
   -> CompositeState s e
   -> Widget sp ep
-createComposite comp state = widget where
+createComposite !comp !state = widget where
   widget = Widget {
     widgetInit = compositeInit comp state,
     widgetMerge = compositeMerge comp state,
@@ -416,15 +417,15 @@ compositeInit
   -> WidgetResult sp ep
 compositeInit comp state wenv widgetComp = newResult where
   CompositeState{..} = state
-  model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
+  !model = getModel comp wenv
+  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
   -- Creates UI using provided function
-  builtRoot = _cmpUiBuilder comp cwenv model
-  tempRoot = cascadeCtx wenv widgetComp builtRoot
+  !builtRoot = _cmpUiBuilder comp cwenv model
+  !tempRoot = cascadeCtx wenv widgetComp builtRoot
 
   WidgetResult root reqs = widgetInit (tempRoot ^. L.widget) cwenv tempRoot
   newEvts = RaiseEvent <$> Seq.fromList (_cmpOnInit comp)
-  newState = state {
+  !newState = state {
     _cpsModel = Just model,
     _cpsRoot = root,
     _cpsWidgetKeyMap = collectWidgetKeys M.empty root
@@ -433,7 +434,7 @@ compositeInit comp state wenv widgetComp = newResult where
   getBaseStyle wenv node = Nothing
   styledComp = initNodeStyle getBaseStyle wenv widgetComp
   tempResult = WidgetResult root (reqs <> newEvts)
-  newResult = toParentResult comp newState wenv styledComp tempResult
+  !newResult = toParentResult comp newState wenv styledComp tempResult
 
 -- | Merge
 compositeMerge
@@ -467,11 +468,11 @@ compositeMerge comp state wenv newComp oldComp = newResult where
     | otherwise = True
   initRequired = not (nodeMatches tempRoot oldRoot)
 
-  WidgetResult newRoot tmpReqs
+  WidgetResult !newRoot !tmpReqs
     | initRequired = widgetInit tempWidget cwenv tempRoot
     | mergeRequired = widgetMerge tempWidget cwenv tempRoot oldRoot
     | otherwise = resultNode oldRoot
-  newState = validState {
+  !newState = validState {
     _cpsModel = Just model,
     _cpsRoot = newRoot,
     _cpsWidgetKeyMap = collectWidgetKeys M.empty newRoot
@@ -492,7 +493,7 @@ compositeMerge comp state wenv newComp oldComp = newResult where
 
   tmpResult = WidgetResult newRoot (tmpReqs <> extraReqs <> evts)
   reducedResult = toParentResult comp newState wenv styledComp tmpResult
-  newResult = handleWidgetIdChange oldComp reducedResult
+  !newResult = handleWidgetIdChange oldComp reducedResult
 
 -- | Dispose
 compositeDispose
@@ -605,18 +606,18 @@ compositeHandleEvent
 compositeHandleEvent comp state wenv widgetComp target evt = result where
   CompositeState{..} = state
   widget = _cpsRoot ^. L.widget
-  model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
+  !model = getModel comp wenv
+  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
   rootEnabled = _cpsRoot ^. L.info . L.enabled
   compVisible = widgetComp ^. L.info . L.visible
   compEnabled = widgetComp ^. L.info . L.enabled
 
   processEvent = toParentResult comp state wenv widgetComp
-  evtResult
+  !evtResult
     | not (compVisible && compEnabled) = Nothing
     | rootEnabled = widgetHandleEvent widget cwenv _cpsRoot target evt
     | otherwise = Nothing
-  result = fmap processEvent evtResult
+  !result = fmap processEvent evtResult
 
 -- | Message handling
 compositeHandleMessage
@@ -628,7 +629,7 @@ compositeHandleMessage
   -> Path
   -> i
   -> Maybe (WidgetResult sp ep)
-compositeHandleMessage comp state@CompositeState{..} wenv widgetComp target arg
+compositeHandleMessage comp state@CompositeState{..} !wenv !widgetComp !target arg
   | isTargetReached widgetComp target = case cast arg of
       Just evt -> Just $ handleMsgEvent comp state wenv widgetComp evt
       Nothing -> case cast arg of
@@ -637,8 +638,8 @@ compositeHandleMessage comp state@CompositeState{..} wenv widgetComp target arg
   | otherwise = fmap processEvent result where
       processEvent = toParentResult comp state wenv widgetComp
       cmpWidget = _cpsRoot ^. L.widget
-      model = getModel comp wenv
-      cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
+      !model = getModel comp wenv
+      !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
       result = widgetHandleMessage cmpWidget cwenv _cpsRoot target arg
 
 -- Preferred size
@@ -717,9 +718,9 @@ compositeRender
 compositeRender comp state wenv widgetComp renderer = action where
   CompositeState{..} = state
   widget = _cpsRoot ^. L.widget
-  model = getModel comp wenv
-  cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
-  action = widgetRender widget cwenv _cpsRoot renderer
+  !model = getModel comp wenv
+  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
+  !action = widgetRender widget cwenv _cpsRoot renderer
 
 handleMsgEvent
   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
@@ -735,10 +736,10 @@ handleMsgEvent comp state wenv widgetComp event = newResult where
     | isJust _cpsModel = fromJust _cpsModel
     | otherwise = getModel comp wenv
   evtHandler = _cmpEventHandler comp
-  cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
-  response = evtHandler cwenv _cpsRoot model event
-  newReqs = evtResponseToRequest widgetComp _cpsWidgetKeyMap <$> response
-  newResult = WidgetResult widgetComp (Seq.fromList (catMaybes newReqs))
+  !cwenv = convertWidgetEnv wenv _cpsWidgetKeyMap model
+  !response = evtHandler cwenv _cpsRoot model event
+  !newReqs = evtResponseToRequest widgetComp _cpsWidgetKeyMap <$> response
+  !newResult = WidgetResult widgetComp (Seq.fromList (catMaybes newReqs))
 
 handleMsgUpdate
   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
@@ -753,8 +754,8 @@ handleMsgUpdate comp state wenv widgetComp fnUpdate = result where
   model
     | isJust _cpsModel = fromJust _cpsModel
     | otherwise = getModel comp wenv
-  newModel = fnUpdate model
-  result
+  !newModel = fnUpdate model
+  !result
     | model == newModel = resultNode widgetComp
     | otherwise = mergeChild comp state wenv newModel _cpsRoot widgetComp
 
@@ -766,7 +767,7 @@ toParentResult
   -> WidgetNode sp ep
   -> WidgetResult s e
   -> WidgetResult sp ep
-toParentResult comp state wenv widgetComp result = newResult where
+toParentResult comp state !wenv !widgetComp !result = newResult where
   WidgetResult newRoot reqs = result
   widgetId = widgetComp ^. L.info . L.widgetId
   newState = state {
@@ -776,7 +777,7 @@ toParentResult comp state wenv widgetComp result = newResult where
     & L.widget .~ createComposite comp newState
   newNode = updateSizeReq comp newState wenv newComp
   newReqs = seqCatMaybes (toParentReq widgetId <$> reqs)
-  newResult = WidgetResult newNode newReqs
+  !newResult = WidgetResult newNode newReqs
 
 evtResponseToRequest
   :: (CompositeModel s, CompositeEvent e, CompositeEvent ep, CompParentModel sp)
@@ -814,15 +815,15 @@ mergeChild comp state wenv newModel widgetRoot widgetComp = newResult where
       & L.info . L.widgetId .~ _cpsRoot ^. L.info . L.widgetId
   builtWidget = builtRoot ^. L.widget
   mergedResult = widgetMerge builtWidget cwenv builtRoot widgetRoot
-  mergedState = state {
+  !mergedState = state {
     _cpsModel = Just newModel,
     _cpsRoot = mergedResult ^. L.node,
     _cpsWidgetKeyMap = collectWidgetKeys M.empty (mergedResult ^. L.node)
   }
-  result = toParentResult comp mergedState wenv widgetComp mergedResult
-  newReqs = widgetDataSet (_cmpWidgetData comp) newModel
+  !result = toParentResult comp mergedState wenv widgetComp mergedResult
+  !newReqs = widgetDataSet (_cmpWidgetData comp) newModel
     ++ fmap ($ newModel) (_cmpOnChangeReq comp)
-  newResult = result
+  !newResult = result
     & L.requests <>~ Seq.fromList newReqs
 
 getModel

src/Monomer/Widgets/Container.hs

@@ -8,6 +8,7 @@ Portability : non-portable
 
 Helper for creating widgets with children elements.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
@@ -433,7 +434,7 @@ createContainer
   => a
   -> Container s e a
   -> Widget s e
-createContainer state container = Widget {
+createContainer !state !container = Widget {
   widgetInit = initWrapper container,
   widgetMerge = mergeWrapper container,
   widgetDispose = disposeWrapper container,
@@ -466,16 +467,16 @@ getUpdateCWenv
   -> WidgetNode s e
   -> Int
   -> WidgetEnv s e
-getUpdateCWenv container wenv node cnode cidx = newWenv where
+getUpdateCWenv container !wenv !node !cnode !cidx = newWenv where
   cOffset = containerChildrenOffset container
   updateCWenv = containerUpdateCWenv container
   layoutDirection = containerLayoutDirection container
-  offsetWenv wenv
+  offsetWenv !wenv
     | isJust cOffset = updateWenvOffset container wenv node
     | otherwise = wenv
-  directionWenv = wenv
+  !directionWenv = wenv
     & L.layoutDirection .~ layoutDirection
-  newWenv = updateCWenv (offsetWenv directionWenv) node cnode cidx
+  !newWenv = updateCWenv (offsetWenv directionWenv) node cnode cidx
 
 {-|
 Helper function that updates widget environment based on current container
@@ -621,7 +622,7 @@ mergeChildren
   -> WidgetNode s e
   -> WidgetResult s e
   -> WidgetResult s e
-mergeChildren updateCWenv wenv newNode oldNode result = newResult where
+mergeChildren updateCWenv !wenv !newNode !oldNode !result = newResult where
   WidgetResult uNode uReqs = result
   oldChildren = oldNode ^. L.children
   oldIts = Seq.mapWithIndex (,) oldChildren
@@ -639,7 +640,7 @@ mergeChildren updateCWenv wenv newNode oldNode result = newResult where
   removedReqs = foldMap _wrRequests removedResults
   mergedNode = uNode & L.children .~ mergedChildren
   newReqs = uReqs <> mergedReqs <> removedReqs
-  newResult = WidgetResult mergedNode newReqs
+  !newResult = WidgetResult mergedNode newReqs
 
 mergeChildSeq
   :: (Int -> WidgetNode s e -> WidgetEnv s e)
@@ -651,25 +652,26 @@ mergeChildSeq
   -> Seq (Int, WidgetNode s e)
   -> (Seq (WidgetResult s e), Seq (WidgetResult s e))
 mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts Empty = res where
-  dispose (idx, child) = case flip M.member newKeys <$> child^. L.info. L.key of
+  isMember = flip M.member newKeys
+  dispose (!idx, !child) = case isMember <$> child ^. L.info . L.key of
     Just True -> WidgetResult child Empty
     _ -> widgetDispose (child ^. L.widget) wenv child
-  removed = fmap dispose oldIts
-  res = (Empty, removed)
+  !removed = fmap dispose oldIts
+  !res = (Empty, removed)
 mergeChildSeq updateCWenv wenv oldKeys newKeys newNode Empty newIts = res where
-  init (idx, child) = widgetInit (child ^. L.widget) wenv child
-  merged = fmap init newIts
-  res = (merged, Empty)
+  init (idx, !child) = widgetInit (child ^. L.widget) wenv child
+  !merged = fmap init newIts
+  !res = (merged, Empty)
 mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where
-  (_, oldChild) :<| oldChildren = oldIts
-  (newIdx, newChild) :<| newChildren = newIts
-  newWidget = newChild ^. L.widget
-  newWidgetId = newChild ^. L.info . L.widgetId
-  newChildKey = newChild ^. L.info . L.key
-  cwenv = updateCWenv newIdx newChild
+  (_, !oldChild) :<| oldChildren = oldIts
+  (!newIdx, !newChild) :<| newChildren = newIts
+  !newWidget = newChild ^. L.widget
+  !newWidgetId = newChild ^. L.info . L.widgetId
+  !newChildKey = newChild ^. L.info . L.key
+  !cwenv = updateCWenv newIdx newChild
 
   oldKeyMatch = newChildKey >>= \key -> M.lookup key oldKeys
-  oldMatch = fromJust oldKeyMatch
+  oldMatch = fromMaybe newNode oldKeyMatch
   isMergeKey = isJust oldKeyMatch && nodeMatches newChild oldMatch
 
   mergedOld = widgetMerge newWidget cwenv newChild oldChild
@@ -677,15 +679,15 @@ mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldIts newIts = res where
   initNew = widgetInit newWidget cwenv newChild
     & L.requests %~ (|> ResizeWidgets newWidgetId)
 
-  (child, oldRest)
+  (!child, !oldRest)
     | nodeMatches newChild oldChild = (mergedOld, oldChildren)
     | isMergeKey = (mergedKey, oldIts)
     | otherwise = (initNew, oldIts)
 
-  (cmerged, cremoved)
+  (!cmerged, !cremoved)
     = mergeChildSeq updateCWenv wenv oldKeys newKeys newNode oldRest newChildren
-  merged = child <| cmerged
-  res = (merged, cremoved)
+  !merged = child <| cmerged
+  !res = (merged, cremoved)
 
 mergeChildrenCheckVisible
   :: WidgetNode s e
@@ -695,7 +697,7 @@ mergeChildrenCheckVisible oldNode result = newResult where
   newNode = result ^. L.node
   widgetId = newNode ^. L.info . L.widgetId
   resizeRequired = childrenVisibleChanged oldNode newNode
-  newResult
+  !newResult
     | resizeRequired = result & L.requests %~ (|> ResizeWidgets widgetId)
     | otherwise = result
 
@@ -733,15 +735,15 @@ disposeWrapper container wenv node = result where
   widgetId = node ^. L.info . L.widgetId
   children = tempNode ^. L.children
 
-  dispose idx child = widgetDispose (child ^. L.widget) cwenv child where
+  dispose !idx !child = widgetDispose (child ^. L.widget) cwenv child where
     cwenv = updateCWenv wenv node child idx
   results = Seq.mapWithIndex dispose children
   newReqs = foldMap _wrRequests results |> ResetWidgetPath widgetId
-  result = WidgetResult node (reqs <> newReqs)
+  !result = WidgetResult node (reqs <> newReqs)
 
 -- | Find next focusable item
 defaultFindNextFocus :: ContainerFindNextFocusHandler s e
-defaultFindNextFocus wenv node direction start = vchildren where
+defaultFindNextFocus !wenv !node !direction !start = vchildren where
   vchildren = Seq.filter (^. L.info . L.visible) (node ^. L.children)
 
 findNextFocusWrapper
@@ -751,13 +753,13 @@ findNextFocusWrapper
   -> FocusDirection
   -> Path
   -> Maybe WidgetNodeInfo
-findNextFocusWrapper container wenv node dir start = nextFocus where
+findNextFocusWrapper container !wenv !node !dir !start = nextFocus where
   handler = containerFindNextFocus container
   handlerResult = handler wenv node dir start
   children
     | dir == FocusBwd = Seq.reverse handlerResult
     | otherwise = handlerResult
-  nextFocus
+  !nextFocus
     | isFocusCandidate node start dir = Just (node ^. L.info)
     | otherwise = findFocusCandidate container wenv dir start node children
 
@@ -770,12 +772,12 @@ findFocusCandidate
   -> Seq (WidgetNode s e)
   -> Maybe WidgetNodeInfo
 findFocusCandidate _ _ _ _ _ Empty = Nothing
-findFocusCandidate container wenv dir start node (ch :<| chs) = result where
+findFocusCandidate container !wenv !dir !start !node (ch :<| chs) = result where
   updateCWenv = getUpdateCWenv container
-  path = node ^. L.info . L.path
-  idx = fromMaybe 0 (Seq.lookup (length path - 1) path)
-  cwenv = updateCWenv wenv node ch idx
-  isWidgetAfterStart
+  !path = node ^. L.info . L.path
+  !idx = fromMaybe 0 (Seq.lookup (length path - 1) path)
+  !cwenv = updateCWenv wenv node ch idx
+  !isWidgetAfterStart
     | dir == FocusBwd = isNodeBeforePath ch start
     | otherwise = isNodeParentOfPath ch start || isNodeAfterPath ch start
 
@@ -786,7 +788,7 @@ findFocusCandidate container wenv dir start node (ch :<| chs) = result where
 
 -- | Find instance matching point
 defaultFindByPoint :: ContainerFindByPointHandler s e
-defaultFindByPoint wenv node start point = result where
+defaultFindByPoint !wenv !node !start !point = result where
   children = node ^. L.children
   pointInWidget wi = wi ^. L.visible && pointInRect point (wi ^. L.viewport)
   result = Seq.findIndexL (pointInWidget . _wnInfo) children
@@ -798,7 +800,7 @@ findByPointWrapper
   -> Path
   -> Point
   -> Maybe WidgetNodeInfo
-findByPointWrapper container wenv node start point = result where
+findByPointWrapper !container !wenv !node !start !point = result where
   offset = fromMaybe def (containerChildrenOffset container)
   updateCWenv = getUpdateCWenv container
   ignoreEmpty = containerIgnoreEmptyArea container
@@ -832,7 +834,7 @@ containerFindBranchByPath
   -> WidgetNode s e
   -> Path
   -> Seq WidgetNodeInfo
-containerFindBranchByPath wenv node path
+containerFindBranchByPath !wenv !node !path
   | info ^. L.path == path = Seq.singleton info
   | isJust nextChild = info <| nextInst (fromJust nextChild)
   | otherwise = Seq.empty
@@ -858,54 +860,56 @@ handleEventWrapper
   -> Path
   -> SystemEvent
   -> Maybe (WidgetResult s e)
-handleEventWrapper container wenv node baseTarget baseEvt
+handleEventWrapper container !wenv !node !baseTarget !baseEvt
   | not (node ^. L.info . L.visible) || isNothing filteredEvt = Nothing
   | targetReached || not targetValid = pResultStyled
-  | otherwise = cResultStyled
+  | otherwise = nextTargetStep pNode target >>= cResultStyled
   where
     -- Having targetValid = False means the next path step is not in
     -- _wiChildren, but may still be valid in the receiving widget
     -- For example, Composite has its own tree of child widgets with (possibly)
     -- different types for Model and Events, and is candidate for the next step
-    offset = fromMaybe def (containerChildrenOffset container)
-    style = containerGetCurrentStyle container wenv node
-    doCursor = not (containerUseCustomCursor container)
+    !offset = fromMaybe def (containerChildrenOffset container)
+    !style = containerGetCurrentStyle container wenv node
+    !doCursor = not (containerUseCustomCursor container)
     updateCWenv = getUpdateCWenv container
     filterHandler = containerFilterEvent container
     eventHandler = containerHandleEvent container
 
-    targetReached = isTargetReached node target
-    targetValid = isTargetValid node target
-    filteredEvt = filterHandler wenv node baseTarget baseEvt
-    (target, evt) = fromMaybe (baseTarget, baseEvt) filteredEvt
+    !targetReached = isTargetReached node target
+    !targetValid = isTargetValid node target
+    !filteredEvt = filterHandler wenv node baseTarget baseEvt
+    (!target, !evt) = fromMaybe (baseTarget, baseEvt) filteredEvt
     -- Event targeted at parent
-    pResult = eventHandler wenv node target evt
+    !pResult = eventHandler wenv node target evt
     pResultStyled = handleStyleChange wenv target style doCursor node evt
       $ handleSizeReqChange container wenv node (Just evt) pResult
-    -- Event targeted at children
     pNode = maybe node (^. L.node) pResult
-    cwenv = updateCWenv wenv pNode child childIdx
-    childIdx = fromJust $ nextTargetStep pNode target
-    children = pNode ^. L.children
-    child = Seq.index children childIdx
-    childWidget = child ^. L.widget
-    cevt = translateEvent (negPoint offset) evt
 
-    childrenIgnored = isJust pResult && ignoreChildren (fromJust pResult)
-    parentIgnored = isJust cResult && ignoreParent (fromJust cResult)
+    -- Event targeted at children
+    cResultStyled childIdx = result where
+      --childIdx = fromJust $ nextTargetStep pNode target
+      children = pNode ^. L.children
+      child = Seq.index children childIdx
+      childWidget = child ^. L.widget
+      cevt = translateEvent (negPoint offset) evt
+      cwenv = updateCWenv wenv pNode child childIdx
 
-    cResult
-      | childrenIgnored || not (child ^. L.info . L.enabled) = Nothing
-      | otherwise = widgetHandleEvent childWidget cwenv child target cevt
-    cResultMerged
-      | parentIgnored = mergeParentChildEvts node Nothing cResult childIdx
-      | otherwise = mergeParentChildEvts pNode pResult cResult childIdx
+      childrenIgnored = isJust pResult && ignoreChildren (fromJust pResult)
+      parentIgnored = isJust cResult && ignoreParent (fromJust cResult)
 
-    cpNode
-      | parentIgnored = node
-      | otherwise = pNode
-    cResultStyled = handleStyleChange cwenv target style doCursor cpNode cevt
-      $ handleSizeReqChange container cwenv cpNode (Just cevt) cResultMerged
+      cResult
+        | childrenIgnored || not (child ^. L.info . L.enabled) = Nothing
+        | otherwise = widgetHandleEvent childWidget cwenv child target cevt
+      cResultMerged
+        | parentIgnored = mergeParentChildEvts node Nothing cResult childIdx
+        | otherwise = mergeParentChildEvts pNode pResult cResult childIdx
+
+      cpNode
+        | parentIgnored = node
+        | otherwise = pNode
+      !result = handleStyleChange cwenv target style doCursor cpNode cevt
+        $ handleSizeReqChange container cwenv cpNode (Just cevt) cResultMerged
 
 mergeParentChildEvts
   :: WidgetNode s e
@@ -943,7 +947,7 @@ handleMessageWrapper
   -> Path
   -> i
   -> Maybe (WidgetResult s e)
-handleMessageWrapper container wenv node target arg
+handleMessageWrapper container !wenv !node !target arg
   | not targetReached && not targetValid = Nothing
   | otherwise = handleSizeReqChange container wenv node Nothing result
   where
@@ -952,19 +956,20 @@ handleMessageWrapper container wenv node target arg
 
     targetReached = isTargetReached node target
     targetValid = isTargetValid node target
-    childIdx = fromJust $ nextTargetStep node target
-    children = node ^. L.children
-    child = Seq.index children childIdx
-    cwenv = updateCWenv wenv node child childIdx
 
-    message = widgetHandleMessage (child ^. L.widget) cwenv child target arg
-    messageResult = updateChild <$> message
-    updateChild cr = cr {
-      _wrNode = replaceChild node (_wrNode cr) childIdx
-    }
+    messageResult childIdx = updateChild <$> message where
+      children = node ^. L.children
+      child = Seq.index children childIdx
+      cwenv = updateCWenv wenv node child childIdx
+
+      message = widgetHandleMessage (child ^. L.widget) cwenv child target arg
+      updateChild !cr = cr {
+        _wrNode = replaceChild node (_wrNode cr) childIdx
+      }
+
     result
       | targetReached = handler wenv node target arg
-      | otherwise = messageResult
+      | otherwise = nextTargetStep node target >>= messageResult
 
 -- | Preferred size
 defaultGetSizeReq :: ContainerGetSizeReqHandler s e
@@ -1049,12 +1054,12 @@ resizeWrapper container wenv node viewport resizeReq = result where
   children = node ^. L.children
 
   (tempRes, assigned) = handler wenv node viewport children
-  resize idx (child, vp) = newChildRes where
-    cwenv = updateCWenv wenv node child idx
+  resize idx (!child, !vp) = newChildRes where
+    !cwenv = updateCWenv wenv node child idx
     tempChildRes = widgetResize (child ^. L.widget) cwenv child vp resizeReq
     cvp = tempChildRes ^. L.node . L.info . L.viewport
     icvp = fromMaybe vp (intersectRects vp cvp)
-    newChildRes = tempChildRes
+    !newChildRes = tempChildRes
       & L.node . L.info . L.viewport .~ (if useChildSize then icvp else vp)
 
   newChildrenRes = Seq.mapWithIndex resize (Seq.zip children assigned)
@@ -1082,7 +1087,7 @@ renderWrapper
   -> WidgetNode s e
   -> Renderer
   -> IO ()
-renderWrapper container wenv node renderer =
+renderWrapper container wenv !node !renderer =
   drawInScissor renderer useScissor viewport $
     drawStyledAction renderer viewport style $ \_ -> do
       renderBefore wenv node renderer
@@ -1115,7 +1120,7 @@ renderWrapper container wenv node renderer =
     useChildrenScissor = isJust childrenScissor
     childrenScissorRect = fromMaybe def childrenScissor
     pairs = Seq.mapWithIndex (,) children
-    cwenv child idx = updateCWenv wenv node child idx
+    cwenv !child !idx = updateCWenv wenv node child idx
 
 -- | Event Handling Helpers
 ignoreChildren :: WidgetResult s e -> Bool
@@ -1128,19 +1133,19 @@ ignoreParent result = not (Seq.null ignoreReqs) where
 
 replaceChild
   :: WidgetNode s e -> WidgetNode s e -> Int -> WidgetNode s e
-replaceChild parent child idx = parent & L.children .~ newChildren where
+replaceChild !parent !child !idx = parent & L.children .~ newChildren where
   newChildren = Seq.update idx child (parent ^. L.children)
 
 cascadeCtx
   :: WidgetEnv s e -> WidgetNode s e -> WidgetNode s e -> Int -> WidgetNode s e
-cascadeCtx wenv parent child idx = newChild where
+cascadeCtx !wenv !parent !child !idx = newChild where
   pInfo = parent ^. L.info
   cInfo = child ^. L.info
   parentPath = pInfo ^. L.path
   parentVisible = pInfo ^. L.visible
   parentEnabled = pInfo ^. L.enabled
-  newPath = parentPath |> idx
-  newChild = child
+  !newPath = parentPath |> idx
+  !newChild = child
     & L.info . L.widgetId .~ WidgetId (wenv ^. L.timestamp) newPath
     & L.info . L.path .~ newPath
     & L.info . L.visible .~ (cInfo ^. L.visible && parentVisible)

src/Monomer/Widgets/Containers/Alert.hs

@@ -9,6 +9,8 @@ Portability : non-portable
 Simple alert dialog, displaying a close button and optional title. Usually
 embedded in a zstack component and displayed/hidden depending on context.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Containers.Alert (
   -- * Configuration
   AlertCfg,

src/Monomer/Widgets/Containers/Box.hs

@@ -24,6 +24,7 @@ label with an image at its side).
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Containers.Box (
   -- * Configuration

src/Monomer/Widgets/Containers/Confirm.hs

@@ -12,6 +12,7 @@ context.
 -}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Containers.Confirm (
   -- * Configuration

src/Monomer/Widgets/Containers/Draggable.hs

@@ -13,6 +13,7 @@ having to implement a custom widget. Usually works in tandem with
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Containers.Draggable (
   -- * Configuration

src/Monomer/Widgets/Containers/DropTarget.hs

@@ -16,6 +16,7 @@ the dragged message, otherwise it will not be raised.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Containers.DropTarget (
   -- * Configuration

src/Monomer/Widgets/Containers/Dropdown.hs

@@ -18,6 +18,7 @@ to use.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.Dropdown (
   -- * Configuration

src/Monomer/Widgets/Containers/Grid.hs

@@ -11,6 +11,7 @@ it requests max width * elements as its width, and the max height as its height.
 The reverse happens for vgrid.
 -}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Containers.Grid (
   -- * Configuration
@@ -108,7 +109,7 @@ makeFixedGrid isHorizontal config = widget where
     where
       vreqs = accesor <$> vchildren
       nreqs = Seq.length vreqs
-      maxSize = foldl1 sizeReqMergeMax vreqs
+      ~maxSize = foldl1 sizeReqMergeMax vreqs
 
   resize wenv node viewport children = resized where
     style = currentStyle wenv node

src/Monomer/Widgets/Containers/Keystroke.hs

@@ -32,6 +32,7 @@ These can be combined, for example:
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Containers.Keystroke (
   -- * Configuration

src/Monomer/Widgets/Containers/Scroll.hs

@@ -23,6 +23,7 @@ Messages:
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.Scroll (
   -- * Configuration
@@ -375,7 +376,9 @@ makeScroll config state = widget where
   checkFwdStyle wenv node = newNode where
     fwdStyle = _scScrollFwdStyle config
     style = node ^. L.info . L.style
-    (parentStyle, childStyle) = fromJust fwdStyle wenv style
+    (parentStyle, childStyle)
+      | isJust fwdStyle = fromJust fwdStyle wenv style
+      | otherwise = def
     newNode
       | isJust fwdStyle = node
         & L.info . L.style .~ parentStyle

src/Monomer/Widgets/Containers/SelectList.hs

@@ -14,6 +14,7 @@ customizable, plus its styling.
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.SelectList (
   -- * Configuration

src/Monomer/Widgets/Containers/Split.hs

@@ -14,6 +14,7 @@ size requirements of each child node.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.Split (
   -- * Configuration

src/Monomer/Widgets/Containers/Stack.hs

@@ -11,6 +11,8 @@ considers the different type of size requirements and assigns space according to
 the logic defined in 'SizeReq'. If the requested fixed space is larger that the
 viewport of the stack, the content will overflow.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Containers.Stack (
   -- * Configuration
   StackCfg,

src/Monomer/Widgets/Containers/ThemeSwitch.hs

@@ -13,6 +13,7 @@ other kind of style configuration, set it on the child node or wrap the
 themeSwitch widget in a "Monomer.Widgets.Containers.Box".
 -}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.ThemeSwitch (
   -- * Configuration

src/Monomer/Widgets/Containers/Tooltip.hs

@@ -16,6 +16,7 @@ element, you may want to use a box.
 -}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.Tooltip (
   -- * Configuration

src/Monomer/Widgets/Containers/ZStack.hs

@@ -15,9 +15,9 @@ The order of the widgets is from bottom to top.
 The container will request the largest combination of horizontal and vertical
 size requested by its child nodes.
 -}
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Containers.ZStack (
   -- * Configuration

src/Monomer/Widgets/Single.hs

@@ -10,6 +10,7 @@ Helper for creating widgets without children elements.
 -}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Single (
   -- * Re-exported modules

src/Monomer/Widgets/Singles/Base/InputField.hs

@@ -18,6 +18,7 @@ and "Monomer.Widgets.Singles.TimeField".
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Base.InputField (
   -- * Configuration
@@ -226,7 +227,7 @@ makeInputField
   => InputFieldCfg s e a
   -> InputFieldState a
   -> Widget s e
-makeInputField config state = widget where
+makeInputField !config !state = widget where
   widget = createSingle state def {
     singleFocusOnBtnPressed = False,
     singleUseCustomCursor = True,
@@ -242,25 +243,25 @@ makeInputField config state = widget where
   }
 
   -- Simpler access to state members
-  currPlaceholder = _ifsPlaceholder state
-  currVal = _ifsCurrValue state
-  currText = _ifsCurrText state
-  currGlyphs = _ifsGlyphs state
-  currPos = _ifsCursorPos state
-  currSel = _ifsSelStart state
-  currOffset = _ifsOffset state
-  currHistory = _ifsHistory state
-  currHistIdx = _ifsHistIdx state
+  !currPlaceholder = _ifsPlaceholder state
+  !currVal = _ifsCurrValue state
+  !currText = _ifsCurrText state
+  !currGlyphs = _ifsGlyphs state
+  !currPos = _ifsCursorPos state
+  !currSel = _ifsSelStart state
+  !currOffset = _ifsOffset state
+  !currHistory = _ifsHistory state
+  !currHistIdx = _ifsHistIdx state
   -- Text/value conversion functions
-  caretW = fromMaybe defCaretW (_ifcCaretWidth config)
-  caretMs = fromMaybe defCaretMs (_ifcCaretMs config)
-  fromText = _ifcFromText config
-  toText = _ifcToText config
-  getModelValue wenv = widgetDataGet (_weModel wenv) (_ifcValue config)
+  !caretW = fromMaybe defCaretW (_ifcCaretWidth config)
+  !caretMs = fromMaybe defCaretMs (_ifcCaretMs config)
+  !fromText = _ifcFromText config
+  !toText = _ifcToText config
+  getModelValue !wenv = widgetDataGet (_weModel wenv) (_ifcValue config)
   -- Mouse select handling options
-  wheelHandler = _ifcWheelHandler config
-  dragHandler = _ifcDragHandler config
-  dragCursor = _ifcDragCursor config
+  !wheelHandler = _ifcWheelHandler config
+  !dragHandler = _ifcDragHandler config
+  !dragCursor = _ifcDragCursor config
 
   getBaseStyle wenv node = _ifcStyle config >>= handler where
     handler lstyle = Just $ collectTheme wenv (cloneLens lstyle)
@@ -504,8 +505,8 @@ makeInputField config state = widget where
       | isKeyboardUndo wenv evt -> moveHistory wenv node state config (-1)
       | isKeyboardRedo wenv evt -> moveHistory wenv node state config 1
       | otherwise -> fmap handleKeyRes keyRes <|> cursorRes where
-          keyRes = handleKeyPress wenv mod code
-          handleKeyRes (newText, newPos, newSel) = result where
+          !keyRes = handleKeyPress wenv mod code
+          handleKeyRes (!newText, !newPos, !newSel) = result where
             result = genInputResult wenv node False newText newPos newSel []
           cursorReq = changeCursorReq validCursor
           cursorRes
@@ -613,8 +614,8 @@ makeInputField config state = widget where
     newOffset = _ifsOffset tempState
     history = _ifsHistory tempState
     histIdx = _ifsHistIdx tempState
-    newStep = HistoryStep stVal newText newPos newSel newOffset
-    newState
+    !newStep = HistoryStep stVal newText newPos newSel newOffset
+    !newState
       | currText == newText = tempState
       | length history == histIdx = tempState {
           _ifsHistory = history |> newStep,
@@ -624,10 +625,10 @@ makeInputField config state = widget where
           _ifsHistory = Seq.take (histIdx - 1) history |> newStep,
           _ifsHistIdx = histIdx
         }
-    newNode = node
+    !newNode = node
       & L.widget .~ makeInputField config newState
     (reqs, events) = genReqsEvents node config state newText newReqs
-    result
+    !result
       | acceptInput || not textAdd = resultReqsEvts newNode reqs events
       | otherwise = resultReqsEvts node reqs events
 
@@ -769,7 +770,7 @@ genReqsEvents
   -> Text
   -> [WidgetRequest s e]
   -> ([WidgetRequest s e], [e])
-genReqsEvents node config state newText newReqs = result where
+genReqsEvents node config !state !newText !newReqs = result where
   widgetId = node ^. L.info . L.widgetId
   resizeOnChange = _ifcResizeOnChange config
   fromText = _ifcFromText config
@@ -782,7 +783,7 @@ genReqsEvents node config state newText newReqs = result where
   stateVal = fromMaybe currVal newVal
   txtChanged = newText /= currText
   valChanged = stateVal /= currVal
-  evtValid
+  !evtValid
     | txtChanged = fmap ($ isValid) (_ifcValidV config)
     | otherwise = []
   reqValid = setModelValid config isValid
@@ -795,8 +796,8 @@ genReqsEvents node config state newText newReqs = result where
   reqOnChange
     | accepted && valChanged = fmap ($ stateVal) (_ifcOnChangeReq config)
     | otherwise = []
-  reqs = newReqs ++ reqUpdateModel ++ reqValid ++ reqResize ++ reqOnChange
-  result = (reqs, evtValid)
+  !reqs = newReqs ++ reqUpdateModel ++ reqValid ++ reqResize ++ reqOnChange
+  !result = (reqs, evtValid)
 
 moveHistory
   :: (InputFieldValue a, WidgetEvent e)
@@ -824,7 +825,8 @@ moveHistory wenv node state config steps = result where
     newState = tempState {
       _ifsHistIdx = clamp 0 lenHistory reqHistIdx
     }
-    newNode = node & L.widget .~ makeInputField config newState
+    !newNode = node
+      & L.widget .~ makeInputField config newState
 
 newStateFromHistory
   :: WidgetEnv s e
@@ -835,7 +837,7 @@ newStateFromHistory
   -> InputFieldState a
 newStateFromHistory wenv node oldState config inputHist = newState where
   HistoryStep hValue hText hPos hSel hOffset = inputHist
-  tempState = oldState { _ifsOffset = hOffset }
+  !tempState = oldState { _ifsOffset = hOffset }
   newState = newTextState wenv node oldState config hValue hText hPos hSel
 
 newTextState
@@ -888,8 +890,8 @@ newTextState wenv node oldState config value text cursor sel = newState where
     | Just cursor == sel = Nothing
     | isJust sel && (justSel < 0 || justSel > T.length text) = Nothing
     | otherwise = sel
-  tmpState = updatePlaceholder wenv node oldState config
-  newState = tmpState {
+  !tmpState = updatePlaceholder wenv node oldState config
+  !newState = tmpState {
     _ifsCurrValue = value,
     _ifsCurrText = text,
     _ifsCursorPos = cursor,
@@ -906,7 +908,7 @@ updatePlaceholder
   -> InputFieldState a
   -> InputFieldCfg s e a
   -> InputFieldState a
-updatePlaceholder wenv node state config = newState where
+updatePlaceholder wenv node !state !config = newState where
   fontMgr = wenv ^. L.fontManager
   style = currentStyle wenv node
   Rect cx cy cw ch = getContentArea node style

src/Monomer/Widgets/Singles/Button.hs

@@ -9,9 +9,11 @@ Portability : non-portable
 Button widget, with support for multiline text. At the most basic level, a
 button consists of a caption and an event to raise when clicked.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Button (
   -- * Configuration
@@ -181,11 +183,11 @@ button_ :: WidgetEvent e => Text -> e -> [ButtonCfg s e] -> WidgetNode s e
 button_ caption handler configs = buttonNode where
   config = onClick handler <> mconcat configs
   widget = makeButton caption config
-  buttonNode = defaultWidgetNode "button" widget
+  !buttonNode = defaultWidgetNode "button" widget
     & L.info . L.focusable .~ True
 
 makeButton :: WidgetEvent e => Text -> ButtonCfg s e -> Widget s e
-makeButton caption config = widget where
+makeButton !caption !config = widget where
   widget = createContainer () def {
     containerAddStyleReq = False,
     containerUseScissor = True,
@@ -198,7 +200,7 @@ makeButton caption config = widget where
     containerResize = resize
   }
 
-  buttonType = fromMaybe ButtonNormal (_btnButtonType config)
+  !buttonType = fromMaybe ButtonNormal (_btnButtonType config)
 
   getBaseStyle wenv node
     | ignoreTheme = Nothing
@@ -220,9 +222,9 @@ makeButton caption config = widget where
     nodeStyle = node ^. L.info . L.style
     labelCfg = _btnLabelCfg config
     labelCurrStyle = labelCurrentStyle childOfFocusedStyle
-    labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
+    !labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
       & L.info . L.style .~ nodeStyle
-    newNode = node
+    !newNode = node
       & L.children .~ Seq.singleton labelNode
 
   init wenv node = result where

src/Monomer/Widgets/Singles/Checkbox.hs

@@ -11,8 +11,10 @@ text, which can be added with a label in the desired position (usually with
 hstack). Alternatively, "Monomer.Widgets.Singles.LabeledCheckbox" provides this
 functionality out of the box.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Checkbox (
   -- * Configuration
@@ -169,7 +171,7 @@ checkboxD_ widgetData configs = checkboxNode where
 
 makeCheckbox
   :: WidgetEvent e => WidgetData s Bool -> CheckboxCfg s e -> Widget s e
-makeCheckbox widgetData config = widget where
+makeCheckbox !widgetData !config = widget where
   widget = createSingle () def {
     singleGetBaseStyle = getBaseStyle,
     singleHandleEvent = handleEvent,

src/Monomer/Widgets/Singles/ColorPicker.hs

@@ -11,6 +11,7 @@ Color picker using sliders and numeric fields.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE Strict #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Monomer.Widgets.Singles.ColorPicker (

src/Monomer/Widgets/Singles/Dial.hs

@@ -11,12 +11,14 @@ value by keyboard arrows, dragging the mouse or using the wheel.
 
 Similar in objective to "Monomer.Widgets.Singles.Slider", but uses less space.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Dial (
   -- * Configuration
@@ -222,7 +224,7 @@ makeDial
   -> DialCfg s e a
   -> DialState
   -> Widget s e
-makeDial field minVal maxVal config state = widget where
+makeDial !field !minVal !maxVal !config !state = widget where
   widget = createSingle state def {
     singleFocusOnBtnPressed = False,
     singleGetBaseStyle = getBaseStyle,
@@ -285,12 +287,12 @@ makeDial field minVal maxVal config state = widget where
         fastSpeed = max 1 $ round (fromIntegral maxPos / 100)
         warpSpeed = max 1 $ round (fromIntegral maxPos / 10)
         vPos pos = clamp 0 maxPos pos
-        newResult newPos = addReqsEvts (resultNode newNode) newVal where
+        newResult !newPos = addReqsEvts (resultNode newNode) newVal where
           newVal = valueFromPos minVal dragRate newPos
-          newState = state { _dlsPos = newPos }
-          newNode = node
+          !newState = state { _dlsPos = newPos }
+          !newNode = node
             & L.widget .~ makeDial field minVal maxVal config newState
-        handleNewPos newPos
+        handleNewPos !newPos
           | vPos newPos /= pos = Just $ newResult (vPos newPos)
           | otherwise = Nothing
 
@@ -383,7 +385,7 @@ posFromPoint minVal maxVal state dragRate stPoint point = (newPos, newVal) where
   newVal = valueFromPos minVal dragRate newPos
 
 valueFromPos :: DialValue a => a -> Rational -> Integer -> a
-valueFromPos minVal dragRate newPos = newVal where
+valueFromPos !minVal !dragRate !newPos = newVal where
   newVal = minVal + fromFractional (dragRate * fromIntegral newPos)
 
 getDialInfo :: WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
@@ -395,8 +397,8 @@ getDialInfo wenv node config = (dialCenter, dialArea) where
   dialW = fromMaybe (theme ^. L.dialWidth) (_dlcWidth config)
   dialL = _rX carea + (_rW carea - dialW) / 2
   dialT = _rY carea + (_rH carea - dialW) / 2
-  dialCenter = Point (dialL + dialW / 2) (dialT + dialW / 2)
-  dialArea = Rect dialL dialT dialW dialW
+  !dialCenter = Point (dialL + dialW / 2) (dialT + dialW / 2)
+  !dialArea = Rect dialL dialT dialW dialW
 
 currentStyleConfig :: Rect -> CurrentStyleCfg s e
 currentStyleConfig dialArea = def

src/Monomer/Widgets/Singles/ExternalLink.hs

@@ -9,9 +9,11 @@ Portability : non-portable
 Provides a clickable link that opens in the system's browser. It uses OS
 services to open the URI, which means not only URLs can be opened.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.ExternalLink (
   -- * Configuration
@@ -145,7 +147,7 @@ externalLink_ caption url configs = externalLinkNode where
 
 makeExternalLink
   :: WidgetEvent e => Text -> Text -> ExternalLinkCfg s e -> Widget s e
-makeExternalLink caption url config = widget where
+makeExternalLink !caption !url !config = widget where
   widget = createContainer () def {
     containerAddStyleReq = False,
     containerUseScissor = True,
@@ -164,11 +166,10 @@ makeExternalLink caption url config = widget where
     nodeStyle = node ^. L.info . L.style
     labelCfg = _elcLabelCfg config
     labelCurrStyle = labelCurrentStyle childOfFocusedStyle
-    labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
+    !labelNode = label_ caption [ignoreTheme, labelCfg, labelCurrStyle]
       & L.info . L.style .~ nodeStyle
-    childNode = labelNode
-    newNode = node
-      & L.children .~ Seq.singleton childNode
+    !newNode = node
+      & L.children .~ Seq.singleton labelNode
 
   init wenv node = result where
     result = resultNode (createChildNode wenv node)

src/Monomer/Widgets/Singles/Image.hs

@@ -15,10 +15,12 @@ Notes:
 - If you choose 'fitNone', adding 'imageRepeatX' and 'imageRepeatY' won't have
   any kind of effect.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Image (
   -- * Configuration
@@ -277,7 +279,7 @@ imageMem_ name imgData imgSize configs = defaultWidgetNode "image" widget where
 
 makeImage
   :: WidgetEvent e => ImageSource -> ImageCfg e -> ImageState -> Widget s e
-makeImage imgSource config state = widget where
+makeImage !imgSource !config !state = widget where
   widget = createSingle state def {
     singleUseScissor = True,
     singleInit = init,
@@ -288,11 +290,11 @@ makeImage imgSource config state = widget where
     singleRender = render
   }
 
-  isImageMem = case imgSource of
+  !isImageMem = case imgSource of
     ImageMem{} -> True
     _ -> False
 
-  imgName source = case source of
+  imgName !source = case source of
     ImageMem path -> path
     ImagePath path -> path
 

src/Monomer/Widgets/Singles/Label.hs

@@ -9,6 +9,7 @@ Portability : non-portable
 Label widget, with support for multiline text.
 -}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Singles.Label (
   -- * Configuration

src/Monomer/Widgets/Singles/LabeledCheckbox.hs

@@ -11,6 +11,7 @@ clickable label.
 -}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Singles.LabeledCheckbox (
   -- * Configuration

src/Monomer/Widgets/Singles/LabeledRadio.hs

@@ -12,6 +12,7 @@ value.
 -}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Singles.LabeledRadio (
   -- * Configuration

src/Monomer/Widgets/Singles/Radio.hs

@@ -12,8 +12,10 @@ which should be added as a label in the desired position (usually with hstack).
 Alternatively, 'Monomer.Widgets.Singles.LabeledRadio' provides this
 functionality out of the box.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Radio (
   -- * Configuration
@@ -154,7 +156,7 @@ radioD_ option widgetData configs = radioNode where
     & L.info . L.focusable .~ True
 
 makeRadio :: (Eq a, WidgetEvent e) => WidgetData s a -> a -> RadioCfg s e a -> Widget s e
-makeRadio field option config = widget where
+makeRadio !field !option !config = widget where
   widget = createSingle () def {
     singleGetBaseStyle = getBaseStyle,
     singleGetCurrentStyle = getCurrentStyle,

src/Monomer/Widgets/Singles/SeparatorLine.hs

@@ -14,7 +14,9 @@ The line has the provided width in the direction orthogonal to the layout
 direction, and takes all the available space in the other direction. In case of
 wanting a shorter line, padding should be used.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.SeparatorLine (
   -- * Configuration
@@ -81,15 +83,13 @@ separatorLine_ configs = defaultWidgetNode "separatorLine" widget where
   widget = makeSeparatorLine config
 
 makeSeparatorLine :: SeparatorLineCfg -> Widget s e
-makeSeparatorLine config = widget where
+makeSeparatorLine !config = widget where
   widget = createSingle () def {
     singleGetBaseStyle = getBaseStyle,
     singleGetSizeReq = getSizeReq,
     singleRender = render
   }
 
-  factor = fromMaybe 0 (_slcFactor config)
-
   getBaseStyle wenv node = Just style where
     style = collectTheme wenv L.separatorLineStyle
 
@@ -97,6 +97,7 @@ makeSeparatorLine config = widget where
     theme = currentTheme wenv node
     direction = wenv ^. L.layoutDirection
     width = fromMaybe (theme ^. L.separatorLineWidth) (_slcWidth config)
+    factor = fromMaybe 0 (_slcFactor config)
 
     isFixed = factor < 0.01
     flexSide = flexSize 10 0.5

src/Monomer/Widgets/Singles/Slider.hs

@@ -12,12 +12,14 @@ value by keyboard arrows, dragging the mouse or using the wheel.
 Similar in objective to 'Monomer.Widgets.Singles.Dial', but more convenient in
 some layouts.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.Slider (
   -- * Configuration
@@ -317,7 +319,7 @@ makeSlider
   -> SliderCfg s e a
   -> SliderState
   -> Widget s e
-makeSlider isHz field minVal maxVal config state = widget where
+makeSlider !isHz !field !minVal !maxVal !config !state = widget where
   widget = createSingle state def {
     singleFocusOnBtnPressed = False,
     singleGetBaseStyle = getBaseStyle,
@@ -373,7 +375,7 @@ makeSlider isHz field minVal maxVal config state = widget where
         fastSpeed = max 1 $ round (fromIntegral maxPos / 100)
         warpSpeed = max 1 $ round (fromIntegral maxPos / 10)
 
-        handleNewPos newPos
+        handleNewPos !newPos
           | validPos /= pos = resultFromPos validPos []
           | otherwise = Nothing
           where
@@ -403,22 +405,22 @@ makeSlider isHz field minVal maxVal config state = widget where
       shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift
       SliderState maxPos pos = state
 
-      resultFromPoint point reqs = resultFromPos newPos reqs where
-        newPos = posFromMouse isHz vp point
+      resultFromPoint !point !reqs = resultFromPos newPos reqs where
+        !newPos = posFromMouse isHz vp point
 
-      resultFromPos newPos extraReqs = Just newResult where
-        newState = state {
+      resultFromPos !newPos !extraReqs = Just newResult where
+        !newState = state {
           _slsPos = newPos
         }
-        newNode = node
+        !newNode = node
           & L.widget .~ makeSlider isHz field minVal maxVal config newState
-        result = resultReqs newNode [RenderOnce]
-        newVal = valueFromPos newPos
+        !result = resultReqs newNode [RenderOnce]
+        !newVal = valueFromPos newPos
 
-        reqs = widgetDataSet field newVal
+        !reqs = widgetDataSet field newVal
           ++ fmap ($ newVal) (_slcOnChangeReq config)
           ++ extraReqs
-        newResult
+        !newResult
           | pos /= newPos = result
               & L.requests <>~ Seq.fromList reqs
           | otherwise = result

src/Monomer/Widgets/Singles/TextArea.hs

@@ -8,11 +8,13 @@ Portability : non-portable
 
 Input field for multiline 'Text'.
 -}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StrictData #-}
 
 module Monomer.Widgets.Singles.TextArea (
   -- * Configuration
@@ -239,7 +241,7 @@ makeTextArea
   -> TextAreaCfg s e
   -> TextAreaState
   -> Widget s e
-makeTextArea wdata config state = widget where
+makeTextArea !wdata !config !state = widget where
   widget = createSingle state def {
     singleInit = init,
     singleMerge = merge,
@@ -249,25 +251,25 @@ makeTextArea wdata config state = widget where
     singleRender = render
   }
 
-  caretMs = fromMaybe defCaretMs (_tacCaretMs config)
-  maxLength = _tacMaxLength config
-  maxLines = _tacMaxLines config
-  getModelValue wenv = widgetDataGet (_weModel wenv) wdata
+  !caretMs = fromMaybe defCaretMs (_tacCaretMs config)
+  !maxLength = _tacMaxLength config
+  !maxLines = _tacMaxLines config
+  getModelValue !wenv = widgetDataGet (_weModel wenv) wdata
   -- State
-  currText = _tasText state
-  textLines = _tasTextLines state
+  !currText = _tasText state
+  !textLines = _tasTextLines state
   -- Helpers
-  validText state = validLen && validLines where
+  validText !state = validLen && validLines where
     text = _tasText state
     lines = _tasTextLines state
     validLen = T.length text <= fromMaybe maxBound maxLength
     validLines = length lines <= fromMaybe maxBound maxLines
-  line idx
+  line !idx
     | idx >= 0 && idx < length textLines = Seq.index textLines idx ^. L.text
     | otherwise = ""
-  lineLen = T.length . line
-  totalLines = length textLines
-  lastPos = (lineLen (totalLines - 1), totalLines)
+  !lineLen = T.length . line
+  !totalLines = length textLines
+  !lastPos = (lineLen (totalLines - 1), totalLines)
 
   init wenv node = resultNode newNode where
     text = getModelValue wenv

src/Monomer/Widgets/Singles/TextDropdown.hs

@@ -11,6 +11,7 @@ Both header and list content is text based. In case a customizable version is
 is needed, 'Monomer.Widgets.Containers.Dropdown' can be used.
 -}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Singles.TextDropdown (
   -- * Configuratiom

src/Monomer/Widgets/Singles/TextField.hs

@@ -12,6 +12,7 @@ Input field for single line 'Text'.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Singles.TextField (
   -- * Configuration

src/Monomer/Widgets/Util/Drawing.hs

@@ -10,6 +10,7 @@ Utility drawing functions. Built on top the lower level primitives provided by
 "Monomer.Graphics.Types.Renderer".
 -}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Util.Drawing (
   drawInScissor,

src/Monomer/Widgets/Util/Focus.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Helper functions for focus handling.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Util.Focus (
   isNodeFocused,
   isNodeInfoFocused,

src/Monomer/Widgets/Util/Hover.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Helper functions for hover related actions.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Util.Hover (
   isPointInNodeVp,
   isPointInNodeEllipse,

src/Monomer/Widgets/Util/Keyboard.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Utility functions for widget keyboard handling.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Util.Keyboard (
   isShortCutControl,
   isKeyboardCopy,

src/Monomer/Widgets/Util/Parser.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Very basic parsing helpers used by numeric input fields.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Util.Parser where
 
 import Control.Applicative ((<|>))

src/Monomer/Widgets/Util/Style.hs

@@ -10,6 +10,7 @@ Helper functions for style related operations.
 -}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Util.Style (
   collectStyleField,

src/Monomer/Widgets/Util/Text.hs

@@ -8,7 +8,7 @@ Portability : non-portable
 
 Helper functions to text related operations in widgets.
 -}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Util.Text (
   getTextMetrics,
@@ -32,13 +32,13 @@ import qualified Monomer.Core.Lens as L
 getTextMetrics :: WidgetEnv s e -> StyleState -> TextMetrics
 getTextMetrics wenv style = textMetrics where
   fontMgr = wenv ^. L.fontManager
-  !textMetrics = computeTextMetrics fontMgr font fontSize
+  textMetrics = computeTextMetrics fontMgr font fontSize
   font = styleFont style
   fontSize = styleFontSize style
 
 -- | Returns the size of the text using the active style and default options.
 getTextSize :: WidgetEnv s e -> StyleState -> Text -> Size
-getTextSize wenv style !text = size where
+getTextSize wenv style text = size where
   fontMgr = wenv ^. L.fontManager
   size = calcTextSize_ fontMgr style SingleLine KeepSpaces Nothing Nothing text
 
@@ -65,7 +65,7 @@ getSingleTextLineRect
   -> AlignTV        -- ^ The vertical alignment.
   -> Text           -- ^ The text to measure.
   -> Rect           -- ^ The used rect. May be larger than the bounding rect.
-getSingleTextLineRect wenv style !rect !alignH !alignV !text = textRect where
+getSingleTextLineRect wenv style rect alignH alignV text = textRect where
   fontMgr = wenv ^. L.fontManager
   font = styleFont style
   fSize = styleFontSize style
@@ -93,9 +93,9 @@ getSingleTextLineRect wenv style !rect !alignH !alignV !text = textRect where
 
 -- | Returns the glyphs of a single line of text.
 getTextGlyphs :: WidgetEnv s e -> StyleState -> Text -> Seq GlyphPos
-getTextGlyphs wenv style !text = glyphs where
+getTextGlyphs wenv style text = glyphs where
   fontMgr = wenv ^. L.fontManager
   font = styleFont style
   fSize = styleFontSize style
   fSpcH = styleFontSpaceH style
-  !glyphs = computeGlyphsPos fontMgr font fSize fSpcH text
+  glyphs = computeGlyphsPos fontMgr font fSize fSpcH text

src/Monomer/Widgets/Util/Theme.hs

@@ -9,6 +9,7 @@ Portability : non-portable
 Helper functions for loading theme values.
 -}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Util.Theme where
 

src/Monomer/Widgets/Util/Types.hs

@@ -8,6 +8,8 @@ Portability : non-portable
 
 Common types for widget related functions.
 -}
+{-# LANGUAGE Strict #-}
+
 module Monomer.Widgets.Util.Types (
   IsHovered,
   IsFocused,

src/Monomer/Widgets/Util/Widget.hs

@@ -10,6 +10,7 @@ Helper functions for widget lifecycle.
 -}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Strict #-}
 
 module Monomer.Widgets.Util.Widget (
   defaultWidgetNode,

test/unit/Monomer/TestUtil.hs

@@ -33,7 +33,6 @@ import Monomer.Graphics
 import Monomer.Main.Handlers
 import Monomer.Main.Types
 import Monomer.Main.Util
-import Monomer.Widgets.Util.Widget
 
 import qualified Monomer.Lens as L