feat: add the lineBreak option

src/Monomer/Core/Combinators.hs

@@ -249,6 +249,10 @@ class CmbTextThroughline t where
   textThroughline = textThroughline_ True
   textThroughline_ :: Bool -> t
 
+-- | How to break texts into lines.
+class CmbTextLineBreak t where
+  textLineBreak :: LineBreak -> t
+
 -- | Does not apply any kind of resizing to fit to container.
 class CmbFitNone t where
   fitNone :: t

src/Monomer/Core/Style.hs

@@ -177,6 +177,9 @@ instance CmbTextOverline TextStyle where
 instance CmbTextThroughline TextStyle where
   textThroughline_ through = def & L.throughline ?~ through
 
+instance CmbTextLineBreak TextStyle where
+  textLineBreak break = def & L.lineBreak ?~ break
+
 -- Padding
 
 instance CmbPadding Padding where
@@ -361,6 +364,9 @@ instance CmbTextThroughline StyleState where
   textThroughline_ False = def
   textThroughline_ True = def & L.text ?~ textThroughline
 
+instance CmbTextLineBreak StyleState where
+  textLineBreak break = def & L.text ?~ textLineBreak break
+
 -- Padding
 instance CmbPadding StyleState where
   padding padd = def & L.padding ?~ padding padd

src/Monomer/Core/StyleTypes.hs

@@ -306,6 +306,15 @@ instance Semigroup Radius where
 instance Monoid Radius where
   mempty = def
 
+-- | Defines how to break texts into lines.
+data LineBreak
+  = OnSpaces
+  | OnCharacters
+  deriving (Eq, Ord, Enum, Show, Generic)
+
+instance Default LineBreak where
+  def = OnSpaces
+
 -- | Text related definitions.
 data TextStyle = TextStyle {
   _txsFont :: Maybe Font,          -- ^ The font type.
@@ -317,7 +326,8 @@ data TextStyle = TextStyle {
   _txsOverline :: Maybe Bool,      -- ^ True if overline should be displayed.
   _txsThroughline :: Maybe Bool,   -- ^ True if throughline should be displayed.
   _txsAlignH :: Maybe AlignTH,     -- ^ Horizontal alignment.
-  _txsAlignV :: Maybe AlignTV      -- ^ Vertical alignment.
+  _txsAlignV :: Maybe AlignTV,     -- ^ Vertical alignment.
+  _txsLineBreak :: Maybe LineBreak -- ^ Line break option.
 } deriving (Eq, Show, Generic)
 
 instance Default TextStyle where
@@ -331,7 +341,8 @@ instance Default TextStyle where
     _txsOverline = Nothing,
     _txsThroughline = Nothing,
     _txsAlignH = Nothing,
-    _txsAlignV = Nothing
+    _txsAlignV = Nothing,
+    _txsLineBreak = Nothing
   }
 
 instance Semigroup TextStyle where
@@ -345,7 +356,8 @@ instance Semigroup TextStyle where
     _txsOverline = _txsOverline ts2 <|> _txsOverline ts1,
     _txsThroughline = _txsThroughline ts2 <|> _txsThroughline ts1,
     _txsAlignH = _txsAlignH ts2 <|> _txsAlignH ts1,
-    _txsAlignV = _txsAlignV ts2 <|> _txsAlignV ts1
+    _txsAlignV = _txsAlignV ts2 <|> _txsAlignV ts1,
+    _txsLineBreak = _txsLineBreak ts2 <|> _txsLineBreak ts1
   }
 
 instance Monoid TextStyle where

src/Monomer/Core/StyleUtil.hs

@@ -25,6 +25,7 @@ module Monomer.Core.StyleUtil (
   styleFontColor,
   styleTextAlignH,
   styleTextAlignV,
+  styleTextLineBreak,
   styleBgColor,
   styleFgColor,
   styleSndColor,
@@ -177,6 +178,11 @@ styleTextAlignV :: StyleState -> AlignTV
 styleTextAlignV style = fromMaybe def alignV where
   alignV = style ^? L.text . _Just . L.alignV . _Just
 
+-- | Returns the line break option of the given style state, or the
+styleTextLineBreak :: StyleState -> LineBreak
+styleTextLineBreak style = fromMaybe def lineBreak where
+  lineBreak = style ^? L.text . _Just . L.lineBreak . _Just
+
 -- | Returns the background color of the given style state, or the default.
 styleBgColor :: StyleState -> Color
 styleBgColor style = fromMaybe def bgColor where

src/Monomer/Graphics/Text.hs

@@ -135,10 +135,11 @@ fitTextToWidth fontMgr style width trim text = resultLines where
   fSize = styleFontSize style
   fSpcH = styleFontSpaceH style
   fSpcV = styleFontSpaceV style
+  break = styleTextLineBreak style
   lineH = _txmLineH metrics
 
   !metrics = computeTextMetrics fontMgr font fSize
-  fitToWidth = fitLineToW fontMgr font fSize fSpcH fSpcV metrics
+  fitToWidth = fitLineToW fontMgr font fSize fSpcH fSpcV metrics break
 
   helper acc line = (cLines <> newLines, newTop) where
     (cLines, cTop) = acc
@@ -261,19 +262,22 @@ fitLineToW
   -> FontSpace
   -> FontSpace
   -> TextMetrics
+  -> LineBreak
   -> Double
   -> Double
   -> TextTrim
   -> Text
   -> Seq TextLine
-fitLineToW fontMgr font fSize fSpcH fSpcV metrics top width trim text = res where
+fitLineToW fontMgr font fSize fSpcH fSpcV metrics break top width trim text = res where
   spaces = T.replicate 4 " "
   newText = T.replace "\t" spaces text
   !glyphs = computeGlyphsPos fontMgr font fSize fSpcH newText
   -- Do not break line on trailing spaces, they are removed in the next step
   -- In the case of KeepSpaces, lines with only spaces (empty looking) are valid
   keepTailSpaces = trim == TrimSpaces
-  groups = fitGroups (splitGroups glyphs) width keepTailSpaces
+  groups
+    | break == OnCharacters = splitGroups break width glyphs
+    | otherwise = fitGroups (splitGroups break width glyphs) width keepTailSpaces
   resetGroups
     | trim == TrimSpaces = fmap (resetGlyphs . trimGlyphs) groups
     | otherwise = fmap resetGlyphs groups
@@ -413,14 +417,17 @@ isSpaceGroup :: Seq GlyphPos -> Bool
 isSpaceGroup Empty = False
 isSpaceGroup (g :<| gs) = isSpace (_glpGlyph g)
 
-splitGroups :: Seq GlyphPos -> Seq GlyphGroup
-splitGroups Empty = Empty
-splitGroups glyphs = group <| splitGroups rest where
+splitGroups :: LineBreak -> Double -> Seq GlyphPos -> Seq GlyphGroup
+splitGroups _ _ Empty = Empty
+splitGroups break width glyphs = group <| splitGroups break width rest where
   g :<| gs = glyphs
   groupWordFn = not . isWordDelimiter . _glpGlyph
+  groupWidthFn g2 = _glpXMax g2 - _glpXMin g <= width
+  atWord = break == OnSpaces
   (group, rest)
-    | isWordDelimiter (_glpGlyph g) = (Seq.singleton g, gs)
-    | otherwise = Seq.spanl groupWordFn glyphs
+    | atWord && isWordDelimiter (_glpGlyph g) = (Seq.singleton g, gs)
+    | atWord = Seq.spanl groupWordFn glyphs
+    | otherwise = Seq.spanl groupWidthFn glyphs
 
 resetGlyphs :: Seq GlyphPos -> Seq GlyphPos
 resetGlyphs Empty = Empty

test/unit/Monomer/Widgets/Util/TextSpec.hs

@@ -152,6 +152,16 @@ fitTextMulti = describe "fitTextToSize multi line" $ do
     clipKeep "This is    a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` "   a tad"
     clipKeep "This is    a tad bit longer\nMore" ^. ix 2 . L.text `shouldBe` " bit "
 
+  it "should return text broken even in the middle of words, clipped, trimmed, if it does not fit" $ do
+    breakOnChar "This is    really-long\nMore" `shouldSatisfy` elementCount 3
+    breakOnChar "This is    really-long\nMore" ^. ix 0 . L.text `shouldBe` "This is"
+    breakOnChar "This is    really-long\nMore" ^. ix 1 . L.text `shouldBe` "reall"
+    breakOnChar "This is    really-long\nMore" ^. ix 2 . L.text `shouldBe` "y-long"
+    breakOnChar "This is    a tad bit longer\nMore" `shouldSatisfy` elementCount 3
+    breakOnChar "This is    a tad bit longer\nMore" ^. ix 0 . L.text `shouldBe` "This is"
+    breakOnChar "This is    a tad bit longer\nMore" ^. ix 1 . L.text `shouldBe` "a tad"
+    breakOnChar "This is    a tad bit longer\nMore" ^. ix 2 . L.text `shouldBe` "bit lon"
+
   where
     wenv = mockWenv ()
     fontMgr = wenv ^. L.fontManager
@@ -167,6 +177,7 @@ fitTextMulti = describe "fitTextToSize multi line" $ do
     elpsKeep_ size text = fitTextToSize fontMgr style Ellipsis MultiLine KeepSpaces Nothing size text
     clipTrim_ size text = fitTextToSize fontMgr style ClipText MultiLine TrimSpaces Nothing size text
     clipKeep_ size text = fitTextToSize fontMgr style ClipText MultiLine KeepSpaces Nothing size text
+    breakOnChar text = fitTextToSize fontMgr (textLineBreak OnCharacters) ClipText MultiLine TrimSpaces Nothing sizeC text
     elementCount count sq = Seq.length sq == count
 
 fitTextSpace :: Spec