Refactor text metrics operations

app/Main.hs

@@ -30,7 +30,7 @@ main = do
   --      & L.hover . L.fgColor .~ white
   --      & L.focus . L.fgColor .~ white
   let config = [
-        windowSize (1280, 960),
+        --windowSize (1280, 960),
         --windowSize (320, 240),
         useHdpi True,
         appTheme theme,

docs/design-decisions.md

@@ -11,4 +11,4 @@ Why do you use lawless typeclasses for combinators?
 Why isn't StyleState using Phantom Types? Those styleX functions could be made safer.
 Why did you add themes, considering you can easily create a customized version of a widget by just writing a function and using it across the application?
 Why did you remove Margin?
-Why return Maybe from rect/size operations? (word this question properly before answering)
+Why did you switch to returning Maybe from rect/size operations? Revise addOuterSizeReq (word this question properly before answering)

src/Monomer/Graphics/Drawing.hs

@@ -104,7 +104,7 @@ drawStyledBackground :: Renderer -> Rect -> StyleState -> IO ()
 drawStyledBackground renderer rect style =
   drawStyledAction renderer rect style (\_ -> return ())
 
-drawStyledText :: Renderer -> Rect -> StyleState -> Text -> IO TextMetrics
+drawStyledText :: Renderer -> Rect -> StyleState -> Text -> IO Rect
 drawStyledText renderer rect style txt = action where
   action = drawText renderer rect tsFontColor tsFont tsFontSize tsAlign txt
   tsFont = styleFont style
@@ -126,14 +126,14 @@ drawText
   -> FontSize
   -> Align
   -> Text
-  -> IO TextMetrics
+  -> IO Rect
 drawText renderer rect color font fontSize align txt = do
   setFillColor renderer color
   renderText renderer textPos font fontSize txt
-  return textMetrics
+  return textRect
   where
-    textMetrics = computeTextMetrics renderer rect font fontSize align txt
-    TextMetrics tx ty tw th ta td = textMetrics
+    textRect = computeTextRect renderer rect font fontSize align txt
+    Rect tx ty tw th = textRect
     textPos = Point tx (ty + th)
 
 drawImage :: Renderer -> String -> Rect -> Double -> IO ()

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -235,13 +235,23 @@ newRenderer c dpr lock envRef = Renderer {..} where
       ry = h / 2
 
   -- Text
+  computeTextMetrics font fontSize = unsafePerformIO $ do
+    setFont c envRef defaultDpr font fontSize
+    (asc, desc, lineh) <- getTextMetrics c
+
+    return $ TextMetrics {
+      _txhAsc = asc,
+      _txhDesc = desc,
+      _txhLineH = lineh
+    }
+
   computeTextSize font fontSize text = unsafePerformIO $ do
     setFont c envRef dpr font fontSize
     (x1, y1, x2, y2) <- getTextBounds c 0 0 text
 
     return $ Size (realToFrac (x2 - x1) / dpr) (realToFrac (y2 - y1) / dpr)
 
-  computeTextMetrics !rect font fontSize align text = unsafePerformIO $ do
+  computeTextRect !containerRect font fontSize align text = unsafePerformIO $ do
     setFont c envRef defaultDpr font fontSize
     (x1, y1, x2, y2) <- getTextBounds c x y text
     (asc, desc, lineh) <- getTextMetrics c
@@ -256,17 +266,15 @@ newRenderer c dpr lock envRef = Renderer {..} where
          | va == AMiddle = y + h + desc - (h - th) / 2
          | otherwise = y + h + desc
 
-    return $ TextMetrics {
-      _txmX = tx,
-      _txmY = ty - th,
-      _txmW = tw,
-      _txmH = th,
-      _txhAsc = asc,
-      _txhDesc = desc
+    return $ Rect {
+      _rX = tx,
+      _rY = ty - th,
+      _rW = tw,
+      _rH = th
     }
     where
       Align ha va = align
-      Rect x y w h = rect
+      Rect x y w h = containerRect
 
   computeGlyphsPos :: Font -> FontSize -> Text -> Seq GlyphPos
   computeGlyphsPos font fontSize message = unsafePerformIO $ do

src/Monomer/Graphics/Types.hs

@@ -83,22 +83,17 @@ instance Default GlyphPos where
   }
 
 data TextMetrics = TextMetrics {
-  _txmX :: Double,
-  _txmY :: Double,
-  _txmW :: Double,
-  _txmH :: Double,
   _txhAsc :: Double,
-  _txhDesc :: Double
+  _txhDesc :: Double,
+  _txhLineH :: Double
+
 } deriving (Eq, Show)
 
 instance Default TextMetrics where
   def = TextMetrics {
-    _txmX = 0,
-    _txmY = 0,
-    _txmW = 0,
-    _txmH = 0,
     _txhAsc = 0,
-    _txhDesc = 0
+    _txhDesc = 0,
+    _txhLineH = 0
   }
 
 data ImageAddAction
@@ -139,9 +134,10 @@ data Renderer = Renderer {
   renderQuadTo :: Point -> Point -> IO (),
   renderEllipse :: Rect -> IO (),
   -- Text
+  computeTextMetrics :: Font -> FontSize -> TextMetrics,
   computeTextSize :: Font -> FontSize -> Text -> Size,
+  computeTextRect :: Rect -> Font -> FontSize -> Align -> Text -> Rect,
   computeGlyphsPos :: Font -> FontSize -> Text -> Seq GlyphPos,
-  computeTextMetrics :: Rect -> Font -> FontSize -> Align -> Text -> TextMetrics,
   renderText :: Point -> Font -> FontSize -> Text -> IO (),
   -- Image
   addImage :: String -> ImageAddAction -> Size -> ByteString -> IO (),

src/Monomer/Widgets/InputField.hs

@@ -41,6 +41,7 @@ data InputFieldState a = InputFieldState {
   _ifsCursorPos :: !Int,
   _ifsSelStart :: Maybe Int,
   _ifsOffset :: !Double,
+  _ifsTextRect :: Rect,
   _ifsTextMetrics :: TextMetrics
 } deriving (Eq, Show, Typeable)
 
@@ -52,6 +53,7 @@ inputFieldState = InputFieldState {
   _ifsCursorPos = 0,
   _ifsSelStart = Nothing,
   _ifsOffset = 0,
+  _ifsTextRect = def,
   _ifsTextMetrics = def
 }
 
@@ -84,7 +86,12 @@ makeInputField config state = widget where
     singleRender = render
   }
 
-  InputFieldState currVal currText currGlyphs currPos currSel _ _ = state
+  currVal = _ifsCurrValue state
+  currText = _ifsCurrText state
+  currGlyphs = _ifsGlyphs state
+  currPos = _ifsCursorPos state
+  currSel = _ifsSelStart state
+
   fromText = _ifcFromText config
   toText = _ifcToText config
   getModelValue wenv = widgetDataGet (_weModel wenv) (_ifcValue config)
@@ -305,7 +312,7 @@ makeInputField config state = widget where
     when (selRequired && isJust currSel) $
       drawRect renderer selRect (Just selColor) Nothing
 
-    renderContent renderer textMetrics style currText
+    renderContent renderer state style currText
 
     when caretRequired $
       drawRect renderer caretRect (Just caretColor) Nothing
@@ -315,8 +322,10 @@ makeInputField config state = widget where
       style = activeStyle wenv inst
       contentArea = getContentArea style inst
       Rect cx cy cw ch = contentArea
+      textRect = _ifsTextRect state
       textMetrics = _ifsTextMetrics state
-      TextMetrics tx ty tw th ta td = textMetrics
+      Rect tx ty tw th = textRect
+      TextMetrics ta td tl = textMetrics
       selRect = maybe def mkSelRect currSel
       mkSelRect end
         | currPos > end = Rect (tx + gx end) (ty - td) (gw end (currPos - 1)) th
@@ -337,12 +346,15 @@ makeInputField config state = widget where
       caretX tx = max 0 $ min (cx + cw - caretWidth) (tx + caretPos)
       caretRect = Rect (caretX tx) (ty - td) caretWidth th
 
-renderContent :: Renderer -> TextMetrics -> StyleState -> Text -> IO ()
-renderContent renderer textMetrics style currText = do
+renderContent
+  :: (Eq a, Default a, Typeable a)
+  => Renderer -> InputFieldState a -> StyleState -> Text -> IO ()
+renderContent renderer state style currText = do
   setFillColor renderer tsFontColor
   renderText renderer textPos tsFont tsFontSize currText
   where
-    TextMetrics tx ty tw th ta td = textMetrics
+    Rect tx ty tw th = _ifsTextRect state
+    TextMetrics ta td tl = _ifsTextMetrics state
     textPos = Point tx (ty + th)
     textStyle = fromMaybe def (_sstText style)
     tsFont = styleFont style
@@ -366,7 +378,9 @@ newTextState wenv inst oldState value text cursor selection = newState where
   contentArea = getContentArea style inst
   !(Rect cx cy cw ch) = contentArea
   !textMetrics = getTextMetrics wenv style contentArea align text
-  TextMetrics tx ty tw th ta ts = textMetrics
+  !textRect = getTextRect wenv style contentArea align text
+  TextMetrics ta ts tl = textMetrics
+  Rect tx ty tw th = textRect
   glyphs = getTextGlyphs wenv style text
   g :<| gs = glyphs
   glyphX = maybe 0 _glpXMax $ Seq.lookup (cursor - 1) glyphs
@@ -391,5 +405,6 @@ newTextState wenv inst oldState value text cursor selection = newState where
     _ifsCursorPos = cursor,
     _ifsSelStart = selection,
     _ifsOffset = newOffset,
-    _ifsTextMetrics = textMetrics & L.x .~ tx + newOffset
+    _ifsTextRect = textRect & L.x .~ tx + newOffset,
+    _ifsTextMetrics = textMetrics
   }

src/Monomer/Widgets/Label.hs

@@ -6,24 +6,31 @@ module Monomer.Widgets.Label (
 import Control.Applicative ((<|>))
 import Data.Default
 import Data.Maybe
+import Data.Sequence (Seq)
 import Data.Text (Text)
 
+import qualified Data.Sequence as Seq
+import qualified Data.Text as T
+
 import Monomer.Widgets.Single
 
 import qualified Monomer.Lens as L
 
-newtype LabelCfg = LabelCfg {
-  _lscTextOverflow :: Maybe TextOverflow
+data LabelCfg = LabelCfg {
+  _lscTextOverflow :: Maybe TextOverflow,
+  _lscMultiLine :: Maybe Bool
 }
 
 instance Default LabelCfg where
   def = LabelCfg {
-    _lscTextOverflow = Nothing
+    _lscTextOverflow = Nothing,
+    _lscMultiLine = Nothing
   }
 
 instance Semigroup LabelCfg where
   (<>) l1 l2 = LabelCfg {
-    _lscTextOverflow = _lscTextOverflow l2 <|> _lscTextOverflow l1
+    _lscTextOverflow = _lscTextOverflow l2 <|> _lscTextOverflow l1,
+    _lscMultiLine = _lscMultiLine l2 <|> _lscMultiLine l1
   }
 
 instance Monoid LabelCfg where

src/Monomer/Widgets/Util/Text.hs

@@ -2,8 +2,9 @@
 
 module Monomer.Widgets.Util.Text (
   fitText,
-  getTextSize,
   getTextMetrics,
+  getTextSize,
+  getTextRect,
   getTextGlyphs,
   getGlyphsMin,
   getGlyphsMax,
@@ -20,17 +21,25 @@ import Monomer.Core
 import Monomer.Graphics
 import Monomer.Widgets.Util.Style
 
+getTextMetrics
+  :: WidgetEnv s e -> StyleState -> Rect -> Align -> Text -> TextMetrics
+getTextMetrics wenv style !rect !align !text = textMetrics where
+  renderer = _weRenderer wenv
+  !textMetrics = computeTextMetrics renderer font fontSize
+  font = styleFont style
+  fontSize = styleFontSize style
+
 getTextSize :: WidgetEnv s e -> StyleState -> Text -> Size
 getTextSize wenv style !text = textBounds where
   font = styleFont style
   fontSize = styleFontSize style
   !textBounds = computeTextSize (_weRenderer wenv) font fontSize text
 
-getTextMetrics
-  :: WidgetEnv s e -> StyleState -> Rect -> Align -> Text -> TextMetrics
-getTextMetrics wenv style !rect !align !text = textMetrics where
+getTextRect
+  :: WidgetEnv s e -> StyleState -> Rect -> Align -> Text -> Rect
+getTextRect wenv style !rect !align !text = textRect where
   renderer = _weRenderer wenv
-  !textMetrics = computeTextMetrics renderer rect font fontSize align text
+  !textRect = computeTextRect renderer rect font fontSize align text
   font = styleFont style
   fontSize = styleFontSize style
 

tasks.md

@@ -245,8 +245,10 @@
     - Also handle hover so scrollbars get correct cursor
 
 - Pending
-  - Check 1px difference on right side of labels/buttons
   - Multiline label
+  - Check 1px difference on right side of labels/buttons
+  - Check displaced textField when adding characters on right align
+    - Also, when right is reached from left, everything is pushed out of screen
   - Add testing
     - Delayed until this point to try to settle down interfaces
     - Validate stack assigns space correctly
@@ -293,6 +295,7 @@ Maybe postponed after release?
   - Create File Selector
   - Create Color Selector
   - Create Layout with width/heights specified in percents
+  - Consider https://eugenkiss.github.io/7guis/tasks/
   - Drag & drop for user (add attribute indicating if component supports being source/target)
     - Add new request types (drag started, drag stopped, drag cancelled)
     - Add new events (drag hover)