Fix issue when splitting multi line text

app/Main.hs

@@ -102,11 +102,13 @@ handleAppEvent model evt = case evt of
   _ -> []
 
 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
-buildUI wenv model = trace "Creating UI" widgetTree where
+buildUI wenv model = trace "Creating UI" widgetLV where
   widgetLV = vstack [
-      listView dropdown1 items label
-      ,
-      dropdown_ dropdown1 items label label [maxHeight 200]
+      scroll $ vstack $ (\i -> box $ label ("Label: " <> showt i)) <$> [0..100::Int]
+
+--      listView dropdown1 items label
+--      ,
+--      dropdown_ dropdown1 items label label [maxHeight 200]
     ]
   widgetWindow = vstack [
       hstack [

src/Monomer/Graphics/Types.hs

@@ -108,11 +108,11 @@ instance Default TextMetrics where
   }
 
 data TextLine = TextLine {
-  _tlText :: Text,
-  _tlSize :: Size,
-  _tlRect :: Rect,
-  _tlGlyphs :: Seq GlyphPos,
-  _tlMetrics :: TextMetrics
+  _tlText :: !Text,
+  _tlSize :: !Size,
+  _tlRect :: !Rect,
+  _tlGlyphs :: !(Seq GlyphPos),
+  _tlMetrics :: !TextMetrics
 } deriving (Eq, Show)
 
 data ImageAddAction

src/Monomer/Widgets/Box.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -164,23 +165,23 @@ makeBox config = widget where
     raChild = Rect cx cy (min cw contentW) (min ch contentH)
     ah = fromMaybe ACenter (_boxAlignH config)
     av = fromMaybe AMiddle (_boxAlignV config)
-    vpContent = fromMaybe def (intersectRects viewport contentArea)
-    raAligned = alignInRect ah av contentArea raChild
-    vpAligned = fromMaybe def (intersectRects viewport raAligned)
+    !vpContent = fromMaybe def (intersectRects viewport contentArea)
+    !raAligned = alignInRect ah av contentArea raChild
+    !vpAligned = fromMaybe def (intersectRects viewport raAligned)
     expand = fromMaybe False (_boxExpandContent config)
-    resized
+    !resized
       | expand = (node, Seq.singleton (vpContent, contentArea))
       | otherwise = (node, Seq.singleton (vpAligned, raAligned))
 
 alignInRect :: AlignH -> AlignV -> Rect -> Rect -> Rect
-alignInRect ah av parent child = newRect where
+alignInRect !ah !av !parent !child = newRect where
   tempRect = alignVInRect av parent child
   newRect = alignHInRect ah parent tempRect
 
 alignHInRect :: AlignH -> Rect -> Rect -> Rect
 alignHInRect ah parent child = newRect where
-  Rect px _ pw _ = parent
-  Rect cx cy cw ch = child
+  Rect !px _ !pw _ = parent
+  Rect _ !cy !cw !ch = child
   newX = case ah of
     ALeft -> px
     ACenter -> px + (pw - cw) / 2
@@ -189,8 +190,8 @@ alignHInRect ah parent child = newRect where
 
 alignVInRect :: AlignV -> Rect -> Rect -> Rect
 alignVInRect av parent child = newRect where
-  Rect _ py _ ph = parent
-  Rect cx cy cw ch = child
+  Rect _ !py _ !ph = parent
+  Rect !cx _ !cw !ch = child
   newY = case av of
     ATop -> py
     AMiddle -> py + (ph - ch) / 2

src/Monomer/Widgets/Label.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 module Monomer.Widgets.Label (
   label,
   label_
@@ -146,7 +147,7 @@ makeLabel config state = widget where
     rect = fromMaybe def (removeOuterBounds style renderArea)
     Rect px py pw ph = textRect
     Rect nx ny nw nh = rect
-    fittedLines = fitTextToRect wenv style overflow mode trimSpaces rect caption
+    !fittedLines = fitTextToRect wenv style overflow mode trimSpaces rect caption
     newLines
       | pw == nw && ph == nh = moveTextLines (nx - px) (ny - py) textLines
       | otherwise = fittedLines

src/Monomer/Widgets/Util/Text.hs

@@ -15,8 +15,6 @@ module Monomer.Widgets.Util.Text (
   fitTextToRect
 ) where
 
-import Debug.Trace
-
 import Control.Lens ((&), (+~))
 import Data.Default
 import Data.List (foldl')
@@ -128,7 +126,7 @@ fitTextToRect
   -> Rect
   -> Text
   -> Seq TextLine
-fitTextToRect wenv style overflow mode trim rect text = newTextLines where
+fitTextToRect wenv style overflow mode trim !rect !text = newTextLines where
   Rect cx cy cw ch = rect
   alignH = styleTextAlignH style
   alignV = styleTextAlignV style
@@ -137,7 +135,7 @@ fitTextToRect wenv style overflow mode trim rect text = newTextLines where
   textLines
     | mode == MultiLine = fittedLines
     | otherwise = Seq.take 1 fittedLines
-  newTextLines = alignTextLines rect alignH alignV textLines
+  !newTextLines = alignTextLines rect alignH alignV textLines
 
 alignTextLines :: Rect -> AlignH -> AlignV -> Seq TextLine -> Seq TextLine
 alignTextLines parentRect alignH alignV textLines = newTextLines where
@@ -281,8 +279,10 @@ addEllipsisToTextLine wenv style width textLine = newTextLine where
 
 fitGroups :: Seq GlyphGroup -> Double -> Bool -> Seq GlyphGroup
 fitGroups Empty _ _ = Empty
-fitGroups (g :<| gs) width keepTailSpaces = currentLine <| extraLines where
-  extraGroups = fitExtraGroups gs (width - getGlyphsWidth g) keepTailSpaces
+fitGroups (g :<| gs) !width !keepTailSpaces = currentLine <| extraLines where
+  gW = getGlyphsWidth g
+  gMax = getGlyphsMax g
+  extraGroups = fitExtraGroups gs (width - gW) gMax keepTailSpaces
   (lineGroups, remainingGroups) = extraGroups
   currentLine = g <> lineGroups
   extraLines = fitGroups remainingGroups width keepTailSpaces
@@ -290,16 +290,20 @@ fitGroups (g :<| gs) width keepTailSpaces = currentLine <| extraLines where
 fitExtraGroups
   :: Seq GlyphGroup
   -> Double
+  -> Double
   -> Bool
   -> (Seq GlyphPos, Seq GlyphGroup)
-fitExtraGroups Empty _ _ = (Empty, Empty)
-fitExtraGroups (g :<| gs) width keepTailSpaces
-  | gw <= width || keepSpace = (g <> newFit, newRest)
+fitExtraGroups Empty _ _ _ = (Empty, Empty)
+fitExtraGroups (g :<| gs) !width !prevGMax !keepTailSpaces
+  | gW + wDiff <= width || keepSpace = (g <> newFit, newRest)
   | otherwise = (Empty, g :<| gs)
   where
-    gw = getGlyphsWidth g
+    gW = getGlyphsWidth g
+    gMax = getGlyphsWidth g
+    wDiff = gMax - prevGMax
+    remWidth = width - (gW + wDiff)
     keepSpace = keepTailSpaces && isSpaceGroup g
-    (newFit, newRest) = fitExtraGroups gs (width - gw) keepTailSpaces
+    (newFit, newRest) = fitExtraGroups gs remWidth gMax keepTailSpaces
 
 isSpaceGroup :: Seq GlyphPos -> Bool
 isSpaceGroup Empty = False

tasks.md

@@ -324,6 +324,7 @@
   - Rename WidgetResult's widget to node
   - Remove createThemed and move Alert/Dialog to use composite
   - Restore container changes for controlling merge of children (part of reverted scroll changes)
+  - Draw close button on Dialog
 
 - Pending
   - Add testing
@@ -341,7 +342,6 @@
   - Add user documentation
 
 Maybe postponed after release?
-  - Draw close button on Dialog
   - Check why putting box reduces label's space
     - scroll $ vstack $ (\i -> box $ label ("Label: " <> showt i)) <$> [0..100::Int]
   - Set focus on ButtonDown, not Click