Add support for x height based vertical alignment. Make it default

src/Monomer/Core/Combinators.hs

@@ -195,6 +195,12 @@ class CmbTextAscender t where
   textAscender = textAscender_ True
   textAscender_ :: Bool -> t
 
+-- | Align text to the vertical middle based on the x height.
+class CmbTextLowerX t where
+  textLowerX :: t
+  textLowerX = textLowerX_ True
+  textLowerX_ :: Bool -> t
+
 -- | Align text to the bottom.
 class CmbTextBottom t where
   textBottom :: t

src/Monomer/Core/Style.hs

@@ -148,6 +148,10 @@ instance CmbTextAscender TextStyle where
   textAscender_ False = def
   textAscender_ True = textAlignV ATAscender
 
+instance CmbTextLowerX TextStyle where
+  textLowerX_ False = def
+  textLowerX_ True = textAlignV ATLowerX
+
 instance CmbTextBottom TextStyle where
   textBottom_ False = def
   textBottom_ True = textAlignV ATBottom
@@ -337,6 +341,10 @@ instance CmbTextAscender StyleState where
   textAscender_ False = def
   textAscender_ True = styleTextAlignV ATAscender
 
+instance CmbTextLowerX StyleState where
+  textLowerX_ False = def
+  textLowerX_ True = styleTextAlignV ATLowerX
+
 instance CmbTextBottom StyleState where
   textBottom_ False = def
   textBottom_ True = styleTextAlignV ATBottom

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -289,11 +289,16 @@ newRenderer c dpr lock envRef = Renderer {..} where
   computeTextMetrics !font !fontSize = unsafePerformIO $ do
     setFont c envRef dpr font fontSize
     (asc, desc, lineh) <- getTextMetrics c
+    lowerX <- (V.!? 0) <$> textGlyphPositions c 0 0 "x"
+    let heightLowerX = case lowerX of
+          Just lx -> VG.glyphPosMaxY lx - VG.glyphPosMinY lx
+          Nothing -> realToFrac asc
 
     return $ TextMetrics {
       _txmAsc = asc / dpr,
       _txmDesc = desc / dpr,
-      _txmLineH = lineh / dpr
+      _txmLineH = lineh / dpr,
+      _txmLowerX = realToFrac heightLowerX / dpr
     }
 
   computeTextSize !font !fontSize !text = unsafePerformIO $ do

src/Monomer/Graphics/Text.hs

@@ -24,7 +24,7 @@ module Monomer.Graphics.Text (
   getGlyphsMax
 ) where
 
-import Control.Lens ((&), (^.), (+~))
+import Control.Lens ((&), (^.), (^?), (+~), ix, non)
 import Data.Default
 import Data.List (foldl')
 import Data.Maybe
@@ -91,13 +91,18 @@ calcTextRect
 calcTextRect renderer containerRect font fontSize ha va text = textRect where
   Rect x y w h = containerRect
   Size tw _ = computeTextSize renderer font fontSize text
-  TextMetrics asc desc lineh = computeTextMetrics renderer font fontSize
+  TextMetrics asc desc lineh lowerX = computeTextMetrics renderer font fontSize
   tx | ha == ATLeft = x
      | ha == ATCenter = x + (w - tw) / 2
      | otherwise = x + (w - tw)
+  {-
+  This logic differs from alignTextLines, since it works from bottom to top, but
+  the result is the same.
+  -}
   ty | va == ATTop = y + asc
      | va == ATMiddle = y + h + desc - (h - lineh) / 2
      | va == ATAscender = y + h - (h - asc) / 2
+     | va == ATLowerX = y + h - (h - lowerX) / 2
      | otherwise = y + h + desc
 
   textRect = Rect {
@@ -173,13 +178,16 @@ alignTextLines
 alignTextLines style parentRect textLines = newTextLines where
   Rect _ py _ ph = parentRect
   Size _ th = getTextLinesSize textLines
-  TextMetrics asc _ _ = Seq.index textLines 0 ^. L.metrics
+  TextMetrics asc _ lineH lowerX = (textLines ^? ix 0) ^. non def . L.metrics
+  isSingle = length textLines == 1
   alignH = styleTextAlignH style
   alignV = styleTextAlignV style
   alignOffsetY = case alignV of
     ATTop -> 0
     ATAscender
-      | length textLines == 1 -> (ph - asc) / 2
+      | isSingle -> (ph - asc) / 2
+    ATLowerX
+      | isSingle -> (ph - lowerX) / 2 - (asc - lowerX)
     ATBottom -> ph - th
     ATBaseline -> ph - th
     _ -> (ph - th) / 2 -- ATMiddle

src/Monomer/Graphics/Types.hs

@@ -111,12 +111,13 @@ data AlignTV
   = ATTop
   | ATMiddle
   | ATAscender
+  | ATLowerX
   | ATBottom
   | ATBaseline
   deriving (Eq, Show, Generic)
 
 instance Default AlignTV where
-  def = ATAscender
+  def = ATLowerX
 
 -- | Information of a text glyph instance.
 data GlyphPos = GlyphPos {
@@ -154,16 +155,18 @@ data TextOverflow
 
 -- | Text metrics.
 data TextMetrics = TextMetrics {
-  _txmAsc :: {-# UNPACK #-} !Double,   -- ^ The heigth above the baseline.
-  _txmDesc :: {-# UNPACK #-} !Double,  -- ^ The heigth below the baseline.
-  _txmLineH :: {-# UNPACK #-} !Double  -- ^ The total heigth.
+  _txmAsc :: {-# UNPACK #-} !Double,    -- ^ The height above the baseline.
+  _txmDesc :: {-# UNPACK #-} !Double,   -- ^ The height below the baseline.
+  _txmLineH :: {-# UNPACK #-} !Double,  -- ^ The total height.
+  _txmLowerX :: {-# UNPACK #-} !Double  -- ^ The height of lowercase x.
 } deriving (Eq, Show, Generic)
 
 instance Default TextMetrics where
   def = TextMetrics {
     _txmAsc = 0,
     _txmDesc = 0,
-    _txmLineH = 0
+    _txmLineH = 0,
+    _txmLowerX = 0
   }
 
 -- | A text line with associated rendering information.

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

@@ -660,7 +660,7 @@ makeInputField config state = widget where
       selRect = getSelRect state style
 
 textOffsetY :: TextMetrics -> StyleState -> Double
-textOffsetY (TextMetrics ta td tl) style = offset where
+textOffsetY (TextMetrics ta td tl tlx) style = offset where
   offset = case styleTextAlignV style of
     ATBaseline -> -td
     _ -> 0
@@ -680,7 +680,7 @@ renderContent renderer state style currText = do
 
 getCaretH :: InputFieldState a -> Double
 getCaretH state = ta - td * 2 where
-  TextMetrics ta td tl = _ifsTextMetrics state
+  TextMetrics ta td _ _ = _ifsTextMetrics state
 
 getCaretRect :: InputFieldState a -> StyleState -> Rect -> Rect
 getCaretRect state style carea = caretRect where
@@ -900,7 +900,7 @@ inputFieldAlignH style = fromMaybe ATLeft alignH where
   alignH = style ^? L.text . _Just . L.alignH . _Just
 
 inputFieldAlignV :: StyleState -> AlignTV
-inputFieldAlignV style = fromMaybe ATAscender alignV where
+inputFieldAlignV style = fromMaybe ATLowerX alignV where
   alignV = style ^? L.text . _Just . L.alignV . _Just
 
 delim :: Char -> Bool

src/Monomer/Widgets/Singles/Label.hs

@@ -30,7 +30,7 @@ module Monomer.Widgets.Singles.Label (
 ) where
 
 import Control.Applicative ((<|>))
-import Control.Lens ((&), (^.), (.~), (^?!), ix)
+import Control.Lens ((&), (^.), (.~), (^?), non, ix)
 import Control.Monad (forM_)
 import Data.Default
 import Data.Maybe
@@ -264,8 +264,8 @@ makeLabel config state = widget where
     where
       style = activeStyle wenv node
       viewport = node ^. L.info . L.viewport
-      textMetrics = textLines ^?! ix 0 . L.metrics
-      desc = abs (textMetrics ^. L.desc)
+      textMetrics = textLines ^? ix 0 . L.metrics
+      desc = abs (textMetrics ^. non def . L.desc)
       scissorVp = viewport
         & L.y .~ (viewport ^. L.y - desc)
         & L.h .~ (viewport ^. L.h + desc)

src/Monomer/Widgets/Singles/TextArea.hs

@@ -637,7 +637,7 @@ makeTextArea wdata config state = widget where
 getCaretRect :: TextAreaState -> Rect
 getCaretRect state = caretRect where
   (cursorX, cursorY) = _tasCursorPos state
-  TextMetrics _ _ lineh = _tasTextMetrics state
+  TextMetrics _ _ lineh _ = _tasTextMetrics state
   textLines = _tasTextLines state
   (lineRect, glyphs) = case Seq.lookup cursorY textLines of
     Just tl -> (tl ^. L.rect, tl ^. L.glyphs)
@@ -657,7 +657,7 @@ getSelectionRects :: TextAreaState -> Rect -> [Rect]
 getSelectionRects state contentArea = rects where
   currPos = _tasCursorPos state
   currSel = fromMaybe def (_tasSelStart state)
-  TextMetrics _ desc lineh = _tasTextMetrics state
+  TextMetrics _ _ lineh _ = _tasTextMetrics state
   textLines = _tasTextLines state
   line idx
     | length textLines > idx = Seq.index textLines idx ^. L.text
@@ -818,7 +818,7 @@ replaceSelection textLines currPos currSel addText = result where
 findClosestGlyphPos :: TextAreaState -> Point -> (Int, Int)
 findClosestGlyphPos state point = (newPos, lineIdx) where
   Point x y = point
-  TextMetrics _ _ lineh = _tasTextMetrics state
+  TextMetrics _ _ lineh _ = _tasTextMetrics state
   textLines = _tasTextLines state
   lineIdx = clamp 0 (length textLines - 1) (floor (y / lineh))
   lineGlyphs

src/Monomer/Widgets/Util/Drawing.hs

@@ -127,7 +127,7 @@ drawTextLine renderer style textLine = do
     drawLine renderer (Point tx hy) (Point tr hy) lw (Just fontColor)
   where
     TextLine text size rect glyphs metrics = textLine
-    TextMetrics asc desc lineH = metrics
+    TextMetrics asc desc _ _ = metrics
     Rect tx ty tw th = rect
     tr = tx + tw
     tb = ty + th

stack.yaml

@@ -43,7 +43,7 @@ packages:
 # (e.g., acme-missiles-0.3)
 extra-deps:
   - git: https://github.com/fjvallarino/nanovg-hs
-    commit: bb2fa74d1af58fd04e8794a8053701ba30ec2b08
+    commit: 7596db1bb22167ebdb49bb9387e4dacf8d792c74
   - regex-posix-clib-2.7@sha256:998fca06da3d719818f0691ef0b8b9b7375afeea228cb08bd9e2db53f96b0cd7,1232
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack.yaml.lock

@@ -10,11 +10,11 @@ packages:
     git: https://github.com/fjvallarino/nanovg-hs
     pantry-tree:
       size: 5654
-      sha256: adcda2a2a64a46c7dea05ab1be742b943d9c61a61454764a81bb3265dcdc877a
-    commit: bb2fa74d1af58fd04e8794a8053701ba30ec2b08
+      sha256: 1df0a66a4efd24d1cededf947dd598a7e74cf76e3c6f3039b3eac7ead60c4e12
+    commit: 7596db1bb22167ebdb49bb9387e4dacf8d792c74
   original:
     git: https://github.com/fjvallarino/nanovg-hs
-    commit: bb2fa74d1af58fd04e8794a8053701ba30ec2b08
+    commit: 7596db1bb22167ebdb49bb9387e4dacf8d792c74
 - completed:
     hackage: regex-posix-clib-2.7@sha256:998fca06da3d719818f0691ef0b8b9b7375afeea228cb08bd9e2db53f96b0cd7,1232
     pantry-tree:

tasks.md

@@ -717,21 +717,23 @@
   - Fix button disabled click.
   - Improve disabled styles.
   - timeField does not have a theme section.
+  - Should text be aligned based on ascending instead of line height?
 
 Next
-  - Refactor InputField to use same text centering function as the rest of the library.
-  - Should text be aligned based on ascending instead of line height?
-    - Review Books example.
+  - Check externalLink disabled state click.
+  - Check tooltip vertical alignment.
   - Dropdown should scroll to selected item when opening.
   - Dropdown selected item does not seem to be marked on init.
-  - Check externalLink disabled state click.
-  - Add gap support in scroll?
   - Can image be aligned to right when fitting is applied?
   - Think about rendering with custom beginFrame for some widgets
     - Could work for rounded images.
   - Improve base theme creation (scale argument?)
   - Improve Main module (naming, refactor into smaller functions).
   - Apply threading ideas (sdl-continuous-resize).
+    - Improve window resize situation
+      - SDL does not send resize until operation has finished, making content look ugly because it's not updated
+      - Check SDL_SetEventFilter trick instead of normal polling (https://wiki.libsdl.org/SDL_SetEventFilter)
+    - Use channel to group SDL events, task status and render requests (to avoid checking all the time)
   - Document themes and how widgets use them.
   - Avoid building examples when used as a library.
   - Create ContextMenu (could work similarly to Tooltip).
@@ -740,10 +742,6 @@ Future
   - Check if Windows/Linux also miss top pixel
     - Fix for all if they do
     - If they don't, add custom handling for macOS
-  - Use channel to group SDL events, task status and render requests (to avoid checking all the time)
-  - Improve window resize situation
-    - SDL does not send resize until operation has finished, making content look ugly because it's not updated
-    - Check SDL_SetEventFilter trick instead of normal polling (https://wiki.libsdl.org/SDL_SetEventFilter)
   - Check cross compilation
     - https://github.com/zw3rk/toolchain-wrapper
     - https://medium.com/@zw3rk/a-haskell-cross-compiler-for-ios-7cc009abe208

test/unit/Monomer/TestUtil.hs

@@ -56,7 +56,8 @@ mockTextMetrics :: Font -> FontSize -> TextMetrics
 mockTextMetrics font fontSize = TextMetrics {
   _txmAsc = 15,
   _txmDesc = 5,
-  _txmLineH = 20
+  _txmLineH = 20,
+  _txmLowerX = 10
 }
 
 mockTextSize :: Maybe Double -> Font -> FontSize -> Text -> Size