Make _widgetPreferredSize pure

src/Monomer/Graphics/Drawing.hs

@@ -169,7 +169,7 @@ drawText_ :: (Monad m) => Renderer m -> Rect -> Maybe TextStyle -> T.Text -> m (
 drawText_ renderer viewport style txt = do
   void $ drawText renderer viewport style txt
 
-calcTextBounds :: (Monad m) => Renderer m -> Maybe TextStyle -> T.Text -> m Size
+calcTextBounds :: (Monad m) => Renderer m -> Maybe TextStyle -> T.Text -> Size
 calcTextBounds renderer Nothing txt = calcTextBounds renderer (Just mempty) txt
 calcTextBounds renderer (Just TextStyle{..}) txt =
   let

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -5,6 +5,7 @@ module Monomer.Graphics.NanoVGRenderer (makeRenderer) where
 import Control.Monad (when)
 import Control.Monad.IO.Class
 import Data.Default
+import System.IO.Unsafe
 
 import qualified Data.Text as T
 import qualified NanoVG as VG
@@ -114,8 +115,8 @@ makeRenderer c dpr = Renderer {..} where
 
     return $ Rect (tx / dpr) ((ty - realToFrac asc) / dpr) (realToFrac tw / dpr) (realToFrac th / dpr)
 
-  textBounds _ _ "" = return def
-  textBounds font fontSize message = do
+  textBounds _ _ "" = def
+  textBounds font fontSize message = unsafePerformIO $ do
     liftIO $ VG.fontFace c font
     liftIO $ VG.fontSize c $ realToFrac $ fontSize
     VG.Bounds (VG.V4 x1 y1 x2 y2) <- liftIO $ VG.textBounds c 0 0 message

src/Monomer/Graphics/Renderer.hs

@@ -39,6 +39,6 @@ data Renderer m = (Monad m) => Renderer {
   quadTo :: Point -> Point -> m (),
   ellipse :: Rect -> m (),
   -- Text
-  text :: Rect -> Font -> FontSize -> Align -> T.Text -> m (Rect),
-  textBounds :: Font -> FontSize -> T.Text -> m Size
+  text :: Rect -> Font -> FontSize -> Align -> T.Text -> m Rect,
+  textBounds :: Font -> FontSize -> T.Text -> Size
 }

src/Monomer/Main/Core.hs

@@ -7,6 +7,7 @@ import Control.Concurrent (threadDelay)
 import Control.Monad
 import Control.Monad.Extra
 import Control.Monad.IO.Class
+import Control.Monad.State
 import Data.Maybe
 import Data.Sequence (Seq(..), (<|), (|>), (><))
 import Lens.Micro.Mtl
@@ -48,11 +49,10 @@ runWidgets window c mapp = do
 
   windowSize .= newWindowSize
   ticks <- SDL.ticks
-  widgetRoot <- doInDrawingContext window c $ updateUI renderer mapp empty
+  ctx <- get
+  let widgetRoot = updateUI renderer mapp ctx empty
 
-  let newFocus = findNextFocusable rootPath widgetRoot
-
-  focused .= newFocus
+  focused .= findNextFocusable rootPath widgetRoot
 
   mainLoop window c renderer mapp (fromIntegral ticks) 0 0 widgetRoot
 
@@ -86,9 +86,12 @@ mainLoop window c renderer mapp !prevTicks !tsAccum !frames widgets = do
   (seApp, seAppEvents, seWidgets) <- handleSystemEvents renderer mapp currentApp systemEvents wTasksWidgets
 
   newApp <- handleAppEvents mapp seApp (seAppEvents >< (Seq.fromList uTasksEvents) >< wTasksEvents)
+  mctx <- get
 
-  newWidgets <- bindIf (currentApp /= newApp) (updateUI renderer mapp) seWidgets
-            >>= bindIf (resized || wTasksResize) (resizeWindow window renderer newApp)
+  let updatedWidgets = if currentApp /= newApp
+                          then updateUI renderer mapp mctx seWidgets
+                          else seWidgets
+  newWidgets <- return updatedWidgets >>= bindIf (resized || wTasksResize) (resizeWindow window renderer newApp)
 
   currentFocus <- use focused
   renderWidgets window c renderer (PathContext currentFocus rootPath rootPath) newApp newWidgets startTicks
@@ -103,6 +106,7 @@ mainLoop window c renderer mapp !prevTicks !tsAccum !frames widgets = do
   liftIO $ threadDelay nextFrameDelay
   unless quit (mainLoop window c renderer mapp startTicks newTsAccum newFrameCount newWidgets)
 
+
 handleAppEvents :: (MonomerM s e m) => MonomerApp s e m -> s -> Seq e -> m s
 handleAppEvents mapp app events = do
   let (newApp, tasks) = reduceAppEvents (_appEventHandler mapp) app events
@@ -124,33 +128,29 @@ renderWidgets !window !c !renderer ctx app widgetRoot ticks =
   doInDrawingContext window c $ do
     _widgetRender (_instanceWidget widgetRoot) renderer ticks ctx app widgetRoot
 
-resizeUI :: (Monad m) => Renderer m -> s -> Rect -> WidgetInstance s e m -> m (WidgetInstance s e m)
-resizeUI renderer app assignedRect widgetRoot = do
-  preferredSizes <- _widgetPreferredSize (_instanceWidget widgetRoot) renderer app widgetRoot
+resizeUI :: (Monad m) => Renderer m -> s -> Rect -> WidgetInstance s e m -> WidgetInstance s e m
+resizeUI renderer app assignedRect widgetRoot = newWidgetRoot where
+  widget = _instanceWidget widgetRoot
+  preferredSizes = _widgetPreferredSize widget renderer app widgetRoot
+  newWidgetRoot = _widgetResize widget app assignedRect assignedRect widgetRoot preferredSizes
 
-  return $ _widgetResize (_instanceWidget widgetRoot) app assignedRect assignedRect widgetRoot preferredSizes
-
-updateUI :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> WidgetInstance s e m -> m (WidgetInstance s e m)
-updateUI renderer mapp oldWidgets = do
-  windowSize <- use windowSize
-  app <- use appContext
-
-  let newWidgets = _uiBuilder mapp app
-  let mergedRoot = _widgetMerge (_instanceWidget newWidgets) app newWidgets oldWidgets
-
-  resizeUI renderer app windowSize mergedRoot
+updateUI :: (MonomerM s e m) => Renderer m -> MonomerApp s e m -> MonomerContext s e -> WidgetInstance s e m -> WidgetInstance s e m
+updateUI renderer mapp mctx oldWidgets = resizeUI renderer app windowSize mergedRoot where
+  app = _appContext mctx
+  windowSize = _windowSize mctx
+  newWidgets = _uiBuilder mapp app
+  mergedRoot = _widgetMerge (_instanceWidget newWidgets) app newWidgets oldWidgets
 
 resizeWindow :: (MonomerM s e m) => SDL.Window -> Renderer m -> s -> WidgetInstance s e m -> m (WidgetInstance s e m)
 resizeWindow window renderer app widgetRoot = do
   dpr <- use devicePixelRate
   drawableSize <- getDrawableSize window
   newWindowSize <- getWindowSize window dpr
-  newRoot <- resizeUI renderer app newWindowSize widgetRoot
 
   windowSize .= newWindowSize
   liftIO $ GL.viewport GL.$= (GL.Position 0 0, GL.Size (round $ _rw drawableSize) (round $ _rh drawableSize))
 
-  return newRoot
+  return $ resizeUI renderer app newWindowSize widgetRoot
 
 preProcessEvents :: (MonomerM s e m) => (WidgetInstance s e m) -> [SystemEvent] -> m [SystemEvent]
 preProcessEvents widgets events = do

src/Monomer/Widget/BaseContainer.hs

@@ -26,7 +26,7 @@ import qualified Monomer.Common.Tree as Tr
 
 type WidgetMergeHandler s e m = s -> Maybe WidgetState -> WidgetInstance s e m -> WidgetInstance s e m
 type WidgetEventHandler s e m = PathContext -> SystemEvent -> s -> WidgetInstance s e m -> Maybe (EventResult s e m)
-type WidgetPreferredSizeHandler s e m = Monad m => Renderer m -> s -> Seq (WidgetInstance s e m, Tr.Tree SizeReq) -> m (Tr.Tree SizeReq)
+type WidgetPreferredSizeHandler s e m = Monad m => Renderer m -> s -> Seq (WidgetInstance s e m, Tr.Tree SizeReq) -> Tr.Tree SizeReq
 type WidgetResizeHandler s e m = s -> Rect -> Rect -> Seq (WidgetInstance s e m, Tr.Tree SizeReq) -> Seq (Rect, Rect)
 
 createContainer :: (Monad m) => Widget s e m
@@ -143,7 +143,7 @@ containerHandleCustom ctx arg app widgetInstance
 
 -- | Preferred size
 defaultPreferredSize :: WidgetPreferredSizeHandler s e m
-defaultPreferredSize renderer app childrenPairs = return (Tr.Node current childrenReqs) where
+defaultPreferredSize renderer app childrenPairs = Tr.Node current childrenReqs where
   current = SizeReq {
     _sizeRequested = Size 0 0,
     _sizePolicyWidth = FlexibleSize,
@@ -151,13 +151,10 @@ defaultPreferredSize renderer app childrenPairs = return (Tr.Node current childr
   }
   childrenReqs = fmap snd childrenPairs
 
-containerPreferredSize :: (Monad m) => WidgetPreferredSizeHandler s e m -> Renderer m -> s -> WidgetInstance s e m -> m (Tr.Tree SizeReq)
-containerPreferredSize psHandler renderer app widgetInstance = do
-  let children = _instanceChildren widgetInstance
-
-  childrenReqs <- forM children $ \child -> _widgetPreferredSize (_instanceWidget child) renderer app child
-
-  psHandler renderer app (Seq.zip children childrenReqs)
+containerPreferredSize :: (Monad m) => WidgetPreferredSizeHandler s e m -> Renderer m -> s -> WidgetInstance s e m -> Tr.Tree SizeReq
+containerPreferredSize psHandler renderer app widgetInstance = psHandler renderer app (Seq.zip children childrenReqs) where
+  children = _instanceChildren widgetInstance
+  childrenReqs = flip fmap children $ \child -> _widgetPreferredSize (_instanceWidget child) renderer app child
 
 -- | Resize
 defaultResize :: WidgetResizeHandler s e m

src/Monomer/Widget/BaseWidget.hs

@@ -51,8 +51,8 @@ ignoreHandleEvent ctx evt app widgetInstance = Nothing
 ignoreHandleCustom :: forall i s e m . Typeable i => PathContext -> i -> s -> WidgetInstance s e m -> Maybe (EventResult s e m)
 ignoreHandleCustom ctx evt app widgetInstance = Nothing
 
-ignorePreferredSize :: (Monad m) => Renderer m -> s -> WidgetInstance s e m -> m (Tr.Tree SizeReq)
-ignorePreferredSize renderer app widgetInstance = return $ Tr.singleton SizeReq {
+ignorePreferredSize :: (Monad m) => Renderer m -> s -> WidgetInstance s e m -> Tr.Tree SizeReq
+ignorePreferredSize renderer app widgetInstance = Tr.singleton SizeReq {
   _sizeRequested = Size 0 0,
   _sizePolicyWidth = FlexibleSize,
   _sizePolicyHeight = FlexibleSize

src/Monomer/Widget/Types.hs

@@ -73,7 +73,7 @@ data Widget s e m =
     -- Renderer (mainly for text sizing functions)
     --
     -- Returns: the minimum size desired by the widget
-    _widgetPreferredSize :: Renderer m -> s -> WidgetInstance s e m -> m (Tree SizeReq),
+    _widgetPreferredSize :: Renderer m -> s -> WidgetInstance s e m -> Tree SizeReq,
     -- | Resizes the children of this widget
     --
     -- Vieport assigned to the widget

src/Monomer/Widget/Widgets/Button.hs

@@ -33,11 +33,10 @@ makeButton label onClick = createWidget {
         events = if isPressed then [onClick] else []
       _ -> Nothing
 
-    preferredSize renderer app widgetInstance = do
-      let Style{..} = _instanceStyle widgetInstance
-
-      size <- calcTextBounds renderer _textStyle label
-      return $ singleton (SizeReq size FlexibleSize FlexibleSize)
+    preferredSize renderer app widgetInstance = singleton sizeReq where
+      Style{..} = _instanceStyle widgetInstance
+      size = calcTextBounds renderer _textStyle label
+      sizeReq = SizeReq size FlexibleSize FlexibleSize
 
     render renderer ts ctx app WidgetInstance{..} =
       do

src/Monomer/Widget/Widgets/Grid.hs

@@ -34,7 +34,7 @@ makeFixedGrid isHorizontal = createContainer {
     _widgetResize = containerResize resize
   }
   where
-    preferredSize renderer app childrenPairs = return (Tr.Node reqSize children) where
+    preferredSize renderer app childrenPairs = Tr.Node reqSize children where
       children = fmap snd childrenPairs
       visiblePairs = Seq.filter (_instanceVisible . fst) childrenPairs
       childrenReqs = fmap (Tr.nodeValue . snd) visiblePairs

src/Monomer/Widget/Widgets/Label.hs

@@ -23,11 +23,10 @@ makeLabel caption = createWidget {
     _widgetRender = render
   }
   where
-    preferredSize renderer app widgetInstance = do
-      let Style{..} = _instanceStyle widgetInstance
-
-      size <- calcTextBounds renderer _textStyle (if caption == "" then " " else caption)
-      return . singleton $ SizeReq size FlexibleSize FlexibleSize
+    preferredSize renderer app widgetInstance = singleton sizeReq where
+      Style{..} = _instanceStyle widgetInstance
+      size = calcTextBounds renderer _textStyle (if caption == "" then " " else caption)
+      sizeReq = SizeReq size FlexibleSize FlexibleSize
 
     render renderer ts ctx app WidgetInstance{..} =
       do

src/Monomer/Widget/Widgets/Sandbox.hs

@@ -67,11 +67,10 @@ makeSandbox onClick state = createWidget {
       Just val -> if val == SandboxData2 then Nothing else Nothing
       Nothing -> Nothing
 
-    preferredSize renderer app widgetInstance = do
-      let Style{..} = _instanceStyle widgetInstance
-
-      size <- calcTextBounds renderer _textStyle (T.pack (show (_clickCount state)))
-      return . Tr.singleton $ SizeReq size FlexibleSize FlexibleSize
+    preferredSize renderer app widgetInstance = Tr.singleton sizeReq where
+      Style{..} = _instanceStyle widgetInstance
+      size = calcTextBounds renderer _textStyle (T.pack (show (_clickCount state)))
+      sizeReq = SizeReq size FlexibleSize FlexibleSize
 
     render renderer ts ctx app WidgetInstance{..} =
       do

src/Monomer/Widget/Widgets/Scroll.hs

@@ -81,14 +81,10 @@ makeScroll state@(ScrollState dx dy cs@(Size cw ch)) = createContainer {
                       then currScroll + reqDelta
                       else viewportLimit - childPos
 
-    --preferredSize renderer app childrenPairs = return (Tr.Node reqSize children) where
-    preferredSize renderer app childrenPairs = return (Tr.Node sizeReq childrenReqs) where
-      --reqsTree = fmap snd childrenPairs
-      --childrenReqs = fmap (Tr.nodeValue . snd) childrenPairs
+    preferredSize renderer app childrenPairs = Tr.Node sizeReq childrenReqs where
       childrenReqs = fmap snd childrenPairs
       sizeReq = SizeReq (_sizeRequested . Tr.nodeValue $ Seq.index childrenReqs 0) FlexibleSize FlexibleSize
 
-    --resize app viewport renderArea childrenPairs = assignedAreas where
     resize app viewport renderArea childrenPairs = Seq.singleton (childViewport, childRenderArea) where
       Rect l t w h = viewport
       Size cw2 ch2 = _sizeRequested (Tr.nodeValue . snd $ Seq.index childrenPairs 0)

src/Monomer/Widget/Widgets/Spacer.hs

@@ -22,4 +22,5 @@ makeSpacer = createWidget {
     _widgetPreferredSize = preferredSize
   }
   where
-    preferredSize renderer app widgetInstance = return . singleton $ SizeReq (Size defaultSpace defaultSpace) RemainderSize RemainderSize
+    preferredSize renderer app widgetInstance = singleton sizeReq where
+      sizeReq = SizeReq (Size defaultSpace defaultSpace) RemainderSize RemainderSize

src/Monomer/Widget/Widgets/Stack.hs

@@ -32,7 +32,7 @@ makeStack isHorizontal = createContainer {
     focusable = False
     handleEvent _ _ _ = Nothing
 
-    preferredSize renderer app childrenPairs = return (Node reqSize childrenReqs) where
+    preferredSize renderer app childrenPairs = Node reqSize childrenReqs where
       reqSize = SizeReq (calcPreferredSize childrenPairs) FlexibleSize FlexibleSize
       childrenReqs = fmap snd childrenPairs
 

src/Monomer/Widget/Widgets/TextField.hs

@@ -87,11 +87,10 @@ makeTextField userField tfs@(TextFieldState currText currPos) = createWidget {
       newState = TextFieldState newText newPos
       newInstance = widgetInstance { _instanceWidget = makeTextField userField newState }
   
-    preferredSize renderer app widgetInstance = do
-      let Style{..} = _instanceStyle widgetInstance
-
-      size <- calcTextBounds renderer _textStyle (if currText == "" then " " else currText)
-      return . Tr.singleton $ SizeReq size FlexibleSize FlexibleSize
+    preferredSize renderer app widgetInstance = Tr.singleton sizeReq where
+      Style{..} = _instanceStyle widgetInstance
+      size = calcTextBounds renderer _textStyle (if currText == "" then " " else currText)
+      sizeReq = SizeReq size FlexibleSize FlexibleSize
 
     render renderer ts ctx app WidgetInstance{..} =
       let textStyle = _textStyle _instanceStyle
@@ -103,6 +102,6 @@ makeTextField userField tfs@(TextFieldState currText currPos) = createWidget {
         Rect tl tt _ _ <- drawText renderer renderArea textStyle currText
 
         when True $ do
-          Size sw sh <- calcTextBounds renderer textStyle (if part1 == "" then " " else part1)
+          let Size sw sh = calcTextBounds renderer textStyle (if part1 == "" then " " else part1)
           drawRect renderer (Rect (tl + sw) tt caretWidth sh) (Just textColor) Nothing
           return ()