{-# LANGUAGE StrictData #-}

module NanoUI.Font
  ( GlyphQuad (..)
  , ShapedText (..)
  , ShapedGlyphs (..)
  , FontMetrics (..)
  , FontBackend (..)
  , CustomMeasureFn
  , prepareFontMetrics
  , prepareFontMetricsMany
  , measureTextIO
  , lineWidthIO
  , drawShaped
  , drawGlyph
  , caretX
  , caretXIO
  , selectionSpans
  , monospaceMetrics
  , scaleFontMetrics
  , measureTextWrappedIO
  , wrapTextLinesIO
  , truncateTextIO
  , lineWidth
  , kernedAdvance
  , textIndexAtX
  , tableCellInset
  , widgetContentInset
  , widgetPadding
  , buttonPadding
  , selectPadding
  , menuOuterPad
  , menuItemPadX
  , menuItemRowH
  , menuSepH
  , menuMinW
  , menuAccentW
  , menuAccentInset
  , centeredTextY
  , alignedTextPen
  , textInkEnd
  , isDefaultNodeFont
  , checkboxBoxSize
  , checkboxLeading
  , treeItemPadding
  , treeRowLeading
  , treeChevronRect
  , scrollBarWidth
  , scrollBarSideGap
  , scrollBarGeomFor
  , scrollBarGap
  , scrollBarGutter
  , ScrollBarSlot (..)
  , classifyScrollBar
  , scrollLayoutGutter
  , sliderTrackBounds
  , sliderTrackHeight
  , sliderHandleDiameter
  , sliderHandleSlack
  ) where

import qualified Data.Map.Strict as Map
import Data.Primitive.PrimArray (PrimArray, imapPrimArray, indexPrimArray, mapPrimArray, sizeofPrimArray)
import Data.Text (Text)
import qualified Data.Text as T
import NanoUI.Types (Rect (..), onGrid)
import NanoUI.Style (AlignX (..), FontStyle (..), FontVariant (..), FontWeight (..))

data GlyphQuad = GlyphQuad
  { GlyphQuad -> Float
gqX :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqY :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqW :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqH :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqU0 :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqV0 :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqU1 :: {-# UNPACK #-} !Float
  , GlyphQuad -> Float
gqV1 :: {-# UNPACK #-} !Float
  }
  deriving (GlyphQuad -> GlyphQuad -> Bool
(GlyphQuad -> GlyphQuad -> Bool)
-> (GlyphQuad -> GlyphQuad -> Bool) -> Eq GlyphQuad
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlyphQuad -> GlyphQuad -> Bool
== :: GlyphQuad -> GlyphQuad -> Bool
$c/= :: GlyphQuad -> GlyphQuad -> Bool
/= :: GlyphQuad -> GlyphQuad -> Bool
Eq, Int -> GlyphQuad -> ShowS
[GlyphQuad] -> ShowS
GlyphQuad -> String
(Int -> GlyphQuad -> ShowS)
-> (GlyphQuad -> String)
-> ([GlyphQuad] -> ShowS)
-> Show GlyphQuad
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlyphQuad -> ShowS
showsPrec :: Int -> GlyphQuad -> ShowS
$cshow :: GlyphQuad -> String
show :: GlyphQuad -> String
$cshowList :: [GlyphQuad] -> ShowS
showList :: [GlyphQuad] -> ShowS
Show)

-- | A line of text as the host's shaper laid it out: glyphs chosen and placed
-- with the font's kerning, ligatures and contextual forms, in fallback fonts
-- where the font lacks a character, and right-to-left runs reordered.
data ShapedText = ShapedText
  { ShapedText -> Float
stAdvance :: {-# UNPACK #-} !Float
  , ShapedText -> Float
stInkEnd :: {-# UNPACK #-} !Float
  -- ^ The right edge of the rightmost glyph's ink.
  , ShapedText -> PrimArray Float
stCarets :: !(PrimArray Float)
  -- ^ Where the caret sits before each character, and after the last: one
  -- more entry than the text has characters. A right-to-left run's carets
  -- decrease, and the characters of a cluster share its width.
  }
  deriving (ShapedText -> ShapedText -> Bool
(ShapedText -> ShapedText -> Bool)
-> (ShapedText -> ShapedText -> Bool) -> Eq ShapedText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShapedText -> ShapedText -> Bool
== :: ShapedText -> ShapedText -> Bool
$c/= :: ShapedText -> ShapedText -> Bool
/= :: ShapedText -> ShapedText -> Bool
Eq, Int -> ShapedText -> ShowS
[ShapedText] -> ShowS
ShapedText -> String
(Int -> ShapedText -> ShowS)
-> (ShapedText -> String)
-> ([ShapedText] -> ShowS)
-> Show ShapedText
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShapedText -> ShowS
showsPrec :: Int -> ShapedText -> ShowS
$cshow :: ShapedText -> String
show :: ShapedText -> String
$cshowList :: [ShapedText] -> ShowS
showList :: [ShapedText] -> ShowS
Show)

-- | The glyph quads that draw a shaped line: eight numbers a glyph (x, y,
-- width and height from the pen, then the atlas UVs u0 v0 u1 v1), in logical
-- pixels. Valid until the host's glyph atlas next resets.
newtype ShapedGlyphs = ShapedGlyphs (PrimArray Float)
  deriving (ShapedGlyphs -> ShapedGlyphs -> Bool
(ShapedGlyphs -> ShapedGlyphs -> Bool)
-> (ShapedGlyphs -> ShapedGlyphs -> Bool) -> Eq ShapedGlyphs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShapedGlyphs -> ShapedGlyphs -> Bool
== :: ShapedGlyphs -> ShapedGlyphs -> Bool
$c/= :: ShapedGlyphs -> ShapedGlyphs -> Bool
/= :: ShapedGlyphs -> ShapedGlyphs -> Bool
Eq, Int -> ShapedGlyphs -> ShowS
[ShapedGlyphs] -> ShowS
ShapedGlyphs -> String
(Int -> ShapedGlyphs -> ShowS)
-> (ShapedGlyphs -> String)
-> ([ShapedGlyphs] -> ShowS)
-> Show ShapedGlyphs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShapedGlyphs -> ShowS
showsPrec :: Int -> ShapedGlyphs -> ShowS
$cshow :: ShapedGlyphs -> String
show :: ShapedGlyphs -> String
$cshowList :: [ShapedGlyphs] -> ShowS
showList :: [ShapedGlyphs] -> ShowS
Show)

data FontMetrics = FontMetrics
  { FontMetrics -> Float
fmLineHeight :: {-# UNPACK #-} !Float
  , FontMetrics -> Float
fmAscent :: {-# UNPACK #-} !Float
  -- | Device pixels per logical unit used to snap glyph quads to the pixel
  -- grid. The SDL backend sets this to the window pixel density so text lands on
  -- whole device pixels.
  , FontMetrics -> Float
fmSnapScale :: {-# UNPACK #-} !Float
  , FontMetrics -> Char -> Float
fmAdvance :: Char -> Float
  , FontMetrics -> Char -> Char -> Float
fmKerning :: Char -> Char -> Float
  , FontMetrics -> Text -> Maybe ShapedText
fmShape :: Text -> Maybe ShapedText
  -- ^ The shaped layout of a text the snapshot was prepared for, when the
  -- host shapes. Other texts fall back to 'fmAdvance' and 'fmKerning'.
  , FontMetrics -> Char -> Maybe GlyphQuad
fmGlyph :: Char -> Maybe GlyphQuad
  -- | Optional effectful backend. Pure callbacks above are immutable metric
  -- snapshots; they must never perform font loading or atlas mutation.
  , FontMetrics -> Maybe FontBackend
fmBackend :: Maybe FontBackend
  }

-- | Text preparation performs font queries in IO and returns an immutable
-- snapshot for pure layout. Rasterisation is separate and occurs during draw.
data FontBackend = FontBackend
  { FontBackend -> Text -> IO FontMetrics
fbPrepare :: Text -> IO FontMetrics
  , FontBackend -> Text -> IO (Maybe ShapedGlyphs)
fbDrawShaped :: Text -> IO (Maybe ShapedGlyphs)
  , FontBackend -> Char -> IO (Maybe GlyphQuad)
fbDrawGlyph :: Char -> IO (Maybe GlyphQuad)
  }

-- | Custom node measurement: font metrics and available (width, height) to
-- the node's desired (width, height).
type CustomMeasureFn = FontMetrics -> (Float, Float) -> (Float, Float)

{-# INLINE prepareFontMetrics #-}
prepareFontMetrics :: FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics :: FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
txt = case FontMetrics -> Maybe FontBackend
fmBackend FontMetrics
fm of
  Maybe FontBackend
Nothing -> FontMetrics -> IO FontMetrics
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FontMetrics
fm
  Just FontBackend
backend -> FontBackend -> Text -> IO FontMetrics
fbPrepare FontBackend
backend Text
txt

-- | Prepare a finite text workspace for pure multi-label layout algorithms.
prepareFontMetricsMany :: FontMetrics -> [Text] -> IO FontMetrics
prepareFontMetricsMany :: FontMetrics -> [Text] -> IO FontMetrics
prepareFontMetricsMany FontMetrics
fm [Text]
texts = case FontMetrics -> Maybe FontBackend
fmBackend FontMetrics
fm of
  Maybe FontBackend
Nothing -> FontMetrics -> IO FontMetrics
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FontMetrics
fm
  Just FontBackend
_ -> do
    combined <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm (Text -> [Text] -> Text
T.intercalate Text
"\n" [Text]
texts)
    shapes <- mapM (\Text
t -> do
      prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
t
      pure (t, fmShape prepared t)) texts
    let !byText = [(Text, Maybe ShapedText)] -> Map Text (Maybe ShapedText)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Maybe ShapedText)]
shapes
    pure combined {fmShape = \Text
t -> Maybe ShapedText
-> Text -> Map Text (Maybe ShapedText) -> Maybe ShapedText
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe ShapedText
forall a. Maybe a
Nothing Text
t Map Text (Maybe ShapedText)
byText}

{-# INLINE lineWidthIO #-}
lineWidthIO :: FontMetrics -> Text -> IO Float
lineWidthIO :: FontMetrics -> Text -> IO Float
lineWidthIO FontMetrics
fm Text
txt = do
  prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
txt
  pure $! lineWidth prepared txt

{-# INLINE measureTextIO #-}
measureTextIO :: FontMetrics -> Text -> IO (Float, Float)
measureTextIO :: FontMetrics -> Text -> IO (Float, Float)
measureTextIO FontMetrics
fm Text
txt = do
  prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
txt
  pure $! measureText prepared txt

-- | The glyph quads of a shaped line, placing glyphs in the host's atlas as
-- needed; 'Nothing' when the host does not shape.
{-# INLINE drawShaped #-}
drawShaped :: FontMetrics -> Text -> IO (Maybe ShapedGlyphs)
drawShaped :: FontMetrics -> Text -> IO (Maybe ShapedGlyphs)
drawShaped FontMetrics
fm Text
txt = case FontMetrics -> Maybe FontBackend
fmBackend FontMetrics
fm of
  Maybe FontBackend
Nothing -> Maybe ShapedGlyphs -> IO (Maybe ShapedGlyphs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ShapedGlyphs
forall a. Maybe a
Nothing
  Just FontBackend
backend -> FontBackend -> Text -> IO (Maybe ShapedGlyphs)
fbDrawShaped FontBackend
backend Text
txt

{-# INLINE drawGlyph #-}
drawGlyph :: FontMetrics -> Char -> IO (Maybe GlyphQuad)
drawGlyph :: FontMetrics -> Char -> IO (Maybe GlyphQuad)
drawGlyph FontMetrics
fm Char
c = case FontMetrics -> Maybe FontBackend
fmBackend FontMetrics
fm of
  Maybe FontBackend
Nothing -> Maybe GlyphQuad -> IO (Maybe GlyphQuad)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FontMetrics -> Char -> Maybe GlyphQuad
fmGlyph FontMetrics
fm Char
c)
  Just FontBackend
backend -> FontBackend -> Char -> IO (Maybe GlyphQuad)
fbDrawGlyph FontBackend
backend Char
c

monospaceMetrics :: Float -> FontMetrics
monospaceMetrics :: Float -> FontMetrics
monospaceMetrics Float
cell =
  FontMetrics
    { fmLineHeight :: Float
fmLineHeight = Float
cell
    , fmAscent :: Float
fmAscent = Float
cell Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.8
    , fmSnapScale :: Float
fmSnapScale = Float
1.0
    , fmAdvance :: Char -> Float
fmAdvance = \Char
_ -> Float
cell
    , fmKerning :: Char -> Char -> Float
fmKerning = \Char
_ Char
_ -> Float
0
    , fmShape :: Text -> Maybe ShapedText
fmShape = \Text
_ -> Maybe ShapedText
forall a. Maybe a
Nothing
    , fmGlyph :: Char -> Maybe GlyphQuad
fmGlyph = \Char
_ -> Maybe GlyphQuad
forall a. Maybe a
Nothing
    , fmBackend :: Maybe FontBackend
fmBackend = Maybe FontBackend
forall a. Maybe a
Nothing
    }

scaleFontMetrics :: Float -> FontMetrics -> FontMetrics
scaleFontMetrics :: Float -> FontMetrics -> FontMetrics
scaleFontMetrics Float
s FontMetrics
fm
  | Float
s Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
1.0 = FontMetrics
fm
  | Bool
otherwise =
      FontMetrics
        { fmLineHeight :: Float
fmLineHeight = FontMetrics -> Float
fmLineHeight FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
        , fmAscent :: Float
fmAscent = FontMetrics -> Float
fmAscent FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
        -- Snap scale is a display property, not a font-size property.
        , fmSnapScale :: Float
fmSnapScale = FontMetrics -> Float
fmSnapScale FontMetrics
fm
        , fmAdvance :: Char -> Float
fmAdvance = \Char
c -> FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
c Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
        , fmKerning :: Char -> Char -> Float
fmKerning = \Char
a Char
b -> FontMetrics -> Char -> Char -> Float
fmKerning FontMetrics
fm Char
a Char
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s
        , fmShape :: Text -> Maybe ShapedText
fmShape = \Text
t -> (ShapedText -> ShapedText) -> Maybe ShapedText -> Maybe ShapedText
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShapedText -> ShapedText
scaleShape (FontMetrics -> Text -> Maybe ShapedText
fmShape FontMetrics
fm Text
t)
        , fmGlyph :: Char -> Maybe GlyphQuad
fmGlyph = (GlyphQuad -> GlyphQuad) -> Maybe GlyphQuad -> Maybe GlyphQuad
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlyphQuad -> GlyphQuad
scaleGlyph (Maybe GlyphQuad -> Maybe GlyphQuad)
-> (Char -> Maybe GlyphQuad) -> Char -> Maybe GlyphQuad
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontMetrics -> Char -> Maybe GlyphQuad
fmGlyph FontMetrics
fm
        , fmBackend :: Maybe FontBackend
fmBackend = (FontBackend -> FontBackend)
-> Maybe FontBackend -> Maybe FontBackend
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FontBackend -> FontBackend
scaleBackend (FontMetrics -> Maybe FontBackend
fmBackend FontMetrics
fm)
        }
  where
    scaleBackend :: FontBackend -> FontBackend
scaleBackend FontBackend
backend = FontBackend
      { fbPrepare :: Text -> IO FontMetrics
fbPrepare = \Text
t -> Float -> FontMetrics -> FontMetrics
scaleFontMetrics Float
s (FontMetrics -> FontMetrics) -> IO FontMetrics -> IO FontMetrics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FontBackend -> Text -> IO FontMetrics
fbPrepare FontBackend
backend Text
t
      , fbDrawShaped :: Text -> IO (Maybe ShapedGlyphs)
fbDrawShaped = \Text
t -> (Maybe ShapedGlyphs -> Maybe ShapedGlyphs)
-> IO (Maybe ShapedGlyphs) -> IO (Maybe ShapedGlyphs)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ShapedGlyphs -> ShapedGlyphs)
-> Maybe ShapedGlyphs -> Maybe ShapedGlyphs
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShapedGlyphs -> ShapedGlyphs
scaleGlyphs) (FontBackend -> Text -> IO (Maybe ShapedGlyphs)
fbDrawShaped FontBackend
backend Text
t)
      , fbDrawGlyph :: Char -> IO (Maybe GlyphQuad)
fbDrawGlyph = \Char
c -> (Maybe GlyphQuad -> Maybe GlyphQuad)
-> IO (Maybe GlyphQuad) -> IO (Maybe GlyphQuad)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GlyphQuad -> GlyphQuad) -> Maybe GlyphQuad -> Maybe GlyphQuad
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GlyphQuad -> GlyphQuad
scaleGlyph) (FontBackend -> Char -> IO (Maybe GlyphQuad)
fbDrawGlyph FontBackend
backend Char
c)
      }
    scaleGlyph :: GlyphQuad -> GlyphQuad
scaleGlyph GlyphQuad
gq = GlyphQuad
gq
      { gqX = gqX gq * s, gqY = gqY gq * s
      , gqW = gqW gq * s, gqH = gqH gq * s
      }
    scaleShape :: ShapedText -> ShapedText
scaleShape ShapedText
st =
      ShapedText
st
        { stAdvance = stAdvance st * s
        , stInkEnd = stInkEnd st * s
        , stCarets = mapPrimArray (* s) (stCarets st)
        }
    -- UVs stay in normalised atlas space; only positions and sizes scale.
    scaleGlyphs :: ShapedGlyphs -> ShapedGlyphs
scaleGlyphs (ShapedGlyphs PrimArray Float
quads) =
      PrimArray Float -> ShapedGlyphs
ShapedGlyphs ((Int -> Float -> Float) -> PrimArray Float -> PrimArray Float
forall a b.
(Prim a, Prim b) =>
(Int -> a -> b) -> PrimArray a -> PrimArray b
imapPrimArray (\Int
i Float
v -> if Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 then Float
v Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
s else Float
v) PrimArray Float
quads)

-- | Horizontal text inset of a table cell. Zebra and header fills use the full cell rect.
tableCellInset :: Float
tableCellInset :: Float
tableCellInset = Float
6

{-# INLINE widgetContentInset #-}
widgetContentInset :: FontMetrics -> (Float, Float)
widgetContentInset :: FontMetrics -> (Float, Float)
widgetContentInset FontMetrics
fm =
  let pad :: Float
pad = FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
' ' Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
1.25
   in (Float
pad, Float
pad)

{-# INLINE buttonPadding #-}
buttonPadding :: FontMetrics -> (Float, Float)
buttonPadding :: FontMetrics -> (Float, Float)
buttonPadding FontMetrics
fm =
  let adv :: Float
adv = FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
' '
      lh :: Float
lh = FontMetrics -> Float
fmLineHeight FontMetrics
fm
   in (Float
adv Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2.0, Float
lh Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.30)

{-# INLINE selectPadding #-}
selectPadding :: FontMetrics -> (Float, Float)
selectPadding :: FontMetrics -> (Float, Float)
selectPadding FontMetrics
fm =
  let adv :: Float
adv = FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
' '
      lh :: Float
lh = FontMetrics -> Float
fmLineHeight FontMetrics
fm
   in (Float
adv Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2.0, Float
lh Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.50)

-- Menu metrics shared by the text-field context menu painter, the generic
-- context-menu widgets, and the layout/paint passes, so both menus render
-- identically by construction.

-- | Blank border between the menu panel edge and its rows.
menuOuterPad :: Float
menuOuterPad :: Float
menuOuterPad = Float
6

-- | Extra horizontal inset of a menu row's label past 'menuOuterPad'.
menuItemPadX :: Float
menuItemPadX :: Float
menuItemPadX = Float
10

-- | Fixed height of one menu row.
menuItemRowH :: Float
menuItemRowH :: Float
menuItemRowH = Float
28

-- | Height of a separator band inside a menu.
menuSepH :: Float
menuSepH :: Float
menuSepH = Float
9

-- | Floor for the menu panel width.
menuMinW :: Float
menuMinW :: Float
menuMinW = Float
148

-- | Width of the hover accent marker painted at a menu row's left edge.
menuAccentW :: Float
menuAccentW :: Float
menuAccentW = Float
2

-- | Gap between the hover accent marker and the row's top and bottom edges.
menuAccentInset :: Float
menuAccentInset :: Float
menuAccentInset = Float
3

{-# INLINE centeredTextY #-}
centeredTextY :: FontMetrics -> Float -> Float -> Float -> Float
centeredTextY :: FontMetrics -> Float -> Float -> Float -> Float
centeredTextY FontMetrics
fm Float
y Float
h Float
th =
  case FontMetrics -> Char -> Maybe GlyphQuad
fmGlyph FontMetrics
fm Char
'H' of
    Maybe GlyphQuad
Nothing -> Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
th) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
    Just GlyphQuad
gq -> Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) (Float
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- (GlyphQuad -> Float
gqY GlyphQuad
gq Float -> Float -> Float
forall a. Num a => a -> a -> a
+ GlyphQuad -> Float
gqH GlyphQuad
gq Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2))
  where
    -- Snap the (constant) baseline offset to the device grid rather than the
    -- whole pen: pen = snap(y + offset) rounds a fractional offset with ties
    -- to even, so adjacent rows (and the same row across a sub-pixel scroll)
    -- land on alternating device pixels while the geometry beside them stays
    -- rigid. Snapping only the constant offset keeps every row fixed on the
    -- grid no matter where y falls.

-- Origin and used width inside the node box, inset on all AlignX sides.
{-# INLINE alignedTextBox #-}
alignedTextBox :: AlignX -> Float -> Float -> Float -> Float -> (Float, Float)
alignedTextBox :: AlignX -> Float -> Float -> Float -> Float -> (Float, Float)
alignedTextBox AlignX
ax Float
x Float
w Float
ix Float
tw =
  let contentW :: Float
contentW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ix)
      used :: Float
used = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
tw Float
contentW
      tx :: Float
tx = case AlignX
ax of
        AlignX
AlignEnd -> Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ix Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
used
        AlignX
AlignCenter -> Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
contentW Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
used) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
        AlignX
AlignStart -> Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ix
   in (Float
tx, Float
used)

-- Last glyph ink right in the same space as 'pushText' (pen + gqX + gqW).
-- Falls back to advance when 'fmGlyph' is Nothing (tests).
textInkEnd :: FontMetrics -> Text -> Float
textInkEnd :: FontMetrics -> Text -> Float
textInkEnd FontMetrics
fm Text
txt =
  case Text -> Maybe (Text, Char)
T.unsnoc Text
txt of
    Maybe (Text, Char)
Nothing -> Float
0
    Just (Text
prefix, Char
c) ->
      case FontMetrics -> Text -> Maybe ShapedText
fmShape FontMetrics
fm Text
txt of
        Just ShapedText
st -> ShapedText -> Float
stInkEnd ShapedText
st
        Maybe ShapedText
Nothing ->
          let pen :: Float
pen = FontMetrics -> Text -> Float
lineWidth FontMetrics
fm Text
prefix
           in case FontMetrics -> Char -> Maybe GlyphQuad
fmGlyph FontMetrics
fm Char
c of
                Just GlyphQuad
gq -> Float
pen Float -> Float -> Float
forall a. Num a => a -> a -> a
+ GlyphQuad -> Float
gqX GlyphQuad
gq Float -> Float -> Float
forall a. Num a => a -> a -> a
+ GlyphQuad -> Float
gqW GlyphQuad
gq
                Maybe GlyphQuad
Nothing -> Float
pen Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
c

-- Align using per-glyph advances (same as 'pushText'), not TTF_GetStringSize.
-- When the line fits, AlignEnd/Center shift by ink so the visual right edge
-- stays put as the last character's right bearing changes.
alignedTextPen :: AlignX -> Float -> Float -> Float -> FontMetrics -> Text -> (Float, Float)
alignedTextPen :: AlignX
-> Float -> Float -> Float -> FontMetrics -> Text -> (Float, Float)
alignedTextPen AlignX
ax Float
x Float
w Float
ix FontMetrics
fm Text
txt =
  let tw :: Float
tw = FontMetrics -> Text -> Float
lineWidth FontMetrics
fm Text
txt
      ink :: Float
ink = FontMetrics -> Text -> Float
textInkEnd FontMetrics
fm Text
txt
      contentW :: Float
contentW = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ix)
      used :: Float
used = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
tw Float
contentW
      shift :: Float
shift =
        if Float
tw Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
contentW
          then Float
used
          else case AlignX
ax of
            AlignX
AlignStart -> Float
used
            AlignX
_ -> Float
ink
      (Float
tx, Float
_) = AlignX -> Float -> Float -> Float -> Float -> (Float, Float)
alignedTextBox AlignX
ax Float
x Float
w Float
ix Float
shift
   in (Float
tx, Float
used)

{-# INLINE widgetPadding #-}
widgetPadding :: FontMetrics -> (Float, Float)
widgetPadding :: FontMetrics -> (Float, Float)
widgetPadding FontMetrics
fm =
  let (Float
cx, Float
cy) = FontMetrics -> (Float, Float)
widgetContentInset FontMetrics
fm
   in (Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cx, Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cy)

{-# INLINE checkboxBoxSize #-}
checkboxBoxSize :: FontMetrics -> Float
checkboxBoxSize :: FontMetrics -> Float
checkboxBoxSize FontMetrics
fm = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
22 (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
18 (FontMetrics -> Float
fmLineHeight FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
1.15))

{-# INLINE checkboxLeading #-}
checkboxLeading :: FontMetrics -> Float
checkboxLeading :: FontMetrics -> Float
checkboxLeading FontMetrics
fm = FontMetrics -> Float
checkboxBoxSize FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
8

{-# INLINE treeItemPadding #-}
treeItemPadding :: FontMetrics -> (Float, Float)
treeItemPadding :: FontMetrics -> (Float, Float)
treeItemPadding FontMetrics
fm =
  let lh :: Float
lh = FontMetrics -> Float
fmLineHeight FontMetrics
fm
   in (Float
0, Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
8 (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Float
lh Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.40) :: Int)))

{-# INLINE treeIndentStep #-}
treeIndentStep :: FontMetrics -> Float
treeIndentStep :: FontMetrics -> Float
treeIndentStep FontMetrics
fm = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
12 (FontMetrics -> Float
fmLineHeight FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.85)

{-# INLINE treeChevronLeading #-}
treeChevronLeading :: FontMetrics -> Float
treeChevronLeading :: FontMetrics -> Float
treeChevronLeading FontMetrics
fm = FontMetrics -> Float
checkboxBoxSize FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
6

{-# INLINE treeRowLeading #-}
treeRowLeading :: FontMetrics -> Int -> Float
treeRowLeading :: FontMetrics -> Int -> Float
treeRowLeading FontMetrics
fm Int
depth =
  FontMetrics -> Float
treeIndentStep FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
depth) Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
treeChevronLeading FontMetrics
fm

{-# INLINE treeChevronRect #-}
treeChevronRect :: FontMetrics -> Float -> Float -> Float -> Float -> Int -> Rect
treeChevronRect :: FontMetrics -> Float -> Float -> Float -> Float -> Int -> Rect
treeChevronRect FontMetrics
fm Float
x Float
y Float
_w Float
h Int
depth =
  let indent :: Float
indent = FontMetrics -> Float
treeIndentStep FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
depth)
      lead :: Float
lead = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (FontMetrics -> Float
treeChevronLeading FontMetrics
fm)
   in Float -> Float -> Float -> Float -> Rect
Rect (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
indent) Float
y Float
lead Float
h

sliderTrackHeight :: Float
sliderTrackHeight :: Float
sliderTrackHeight = Float
10

sliderHandleDiameter :: Float
sliderHandleDiameter :: Float
sliderHandleDiameter = Float
18

sliderHandleSlack :: Float
sliderHandleSlack :: Float
sliderHandleSlack = (Float
sliderHandleDiameter Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sliderTrackHeight) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2

{-# INLINE sliderTrackBounds #-}
sliderTrackBounds :: Float -> Float -> Float -> Float -> Rect
sliderTrackBounds :: Float -> Float -> Float -> Float -> Rect
sliderTrackBounds Float
x Float
y Float
w Float
h =
  let trackY :: Float
trackY = Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 ((Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sliderTrackHeight) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
   in Float -> Float -> Float -> Float -> Rect
Rect Float
x Float
trackY (Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
w) Float
sliderTrackHeight

-- | Thickness of a list or page scrollbar.
scrollBarWidth :: Float
scrollBarWidth :: Float
scrollBarWidth = Float
8

-- Window bodies take a slimmer bar.
scrollBarSlimWidth :: Float
scrollBarSlimWidth :: Float
scrollBarSlimWidth = Float
4

scrollBarMargin :: Float
scrollBarMargin :: Float
scrollBarMargin = Float
3

-- | The sliver between a page or window bar and the outer edge, and the
-- smallest gap on either side of a list bar.
scrollBarSideGap :: Float
scrollBarSideGap :: Float
scrollBarSideGap = Float
3

-- | Bar width and end margin for a slot.
scrollBarGeomFor :: ScrollBarSlot -> (Float, Float)
scrollBarGeomFor :: ScrollBarSlot -> (Float, Float)
scrollBarGeomFor ScrollBarSlot
slot =
  case ScrollBarSlot
slot of
    ScrollBarSlot
ScrollBarList -> (Float
scrollBarWidth, Float
scrollBarMargin)
    ScrollBarSlot
ScrollBarPage -> (Float
scrollBarWidth, Float
scrollBarMargin)
    -- Window bar: side gaps only. No end inset.
    ScrollBarSlot
ScrollBarWindow -> (Float
scrollBarSlimWidth, Float
0)

-- | The layout arena stores a scroller's slot as its 'Enum' value, and every
-- other node reads a zero there, so 'ScrollBarList' comes first.
data ScrollBarSlot = ScrollBarList | ScrollBarPage | ScrollBarWindow
  deriving (ScrollBarSlot -> ScrollBarSlot -> Bool
(ScrollBarSlot -> ScrollBarSlot -> Bool)
-> (ScrollBarSlot -> ScrollBarSlot -> Bool) -> Eq ScrollBarSlot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScrollBarSlot -> ScrollBarSlot -> Bool
== :: ScrollBarSlot -> ScrollBarSlot -> Bool
$c/= :: ScrollBarSlot -> ScrollBarSlot -> Bool
/= :: ScrollBarSlot -> ScrollBarSlot -> Bool
Eq, Int -> ScrollBarSlot -> ShowS
[ScrollBarSlot] -> ShowS
ScrollBarSlot -> String
(Int -> ScrollBarSlot -> ShowS)
-> (ScrollBarSlot -> String)
-> ([ScrollBarSlot] -> ShowS)
-> Show ScrollBarSlot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScrollBarSlot -> ShowS
showsPrec :: Int -> ScrollBarSlot -> ShowS
$cshow :: ScrollBarSlot -> String
show :: ScrollBarSlot -> String
$cshowList :: [ScrollBarSlot] -> ShowS
showList :: [ScrollBarSlot] -> ShowS
Show, Int -> ScrollBarSlot
ScrollBarSlot -> Int
ScrollBarSlot -> [ScrollBarSlot]
ScrollBarSlot -> ScrollBarSlot
ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
ScrollBarSlot -> ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
(ScrollBarSlot -> ScrollBarSlot)
-> (ScrollBarSlot -> ScrollBarSlot)
-> (Int -> ScrollBarSlot)
-> (ScrollBarSlot -> Int)
-> (ScrollBarSlot -> [ScrollBarSlot])
-> (ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot])
-> (ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot])
-> (ScrollBarSlot
    -> ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot])
-> Enum ScrollBarSlot
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ScrollBarSlot -> ScrollBarSlot
succ :: ScrollBarSlot -> ScrollBarSlot
$cpred :: ScrollBarSlot -> ScrollBarSlot
pred :: ScrollBarSlot -> ScrollBarSlot
$ctoEnum :: Int -> ScrollBarSlot
toEnum :: Int -> ScrollBarSlot
$cfromEnum :: ScrollBarSlot -> Int
fromEnum :: ScrollBarSlot -> Int
$cenumFrom :: ScrollBarSlot -> [ScrollBarSlot]
enumFrom :: ScrollBarSlot -> [ScrollBarSlot]
$cenumFromThen :: ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
enumFromThen :: ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
$cenumFromTo :: ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
enumFromTo :: ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
$cenumFromThenTo :: ScrollBarSlot -> ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
enumFromThenTo :: ScrollBarSlot -> ScrollBarSlot -> ScrollBarSlot -> [ScrollBarSlot]
Enum)

classifyScrollBar :: Bool -> Bool -> ScrollBarSlot
classifyScrollBar :: Bool -> Bool -> ScrollBarSlot
classifyScrollBar Bool
isWindowBody Bool
isPageGrow
  | Bool
isWindowBody = ScrollBarSlot
ScrollBarWindow
  | Bool
isPageGrow = ScrollBarSlot
ScrollBarPage
  | Bool
otherwise = ScrollBarSlot
ScrollBarList

-- | Gap between the content and a bar, given the padding @trailPad@ on the
-- bar's side: the padding itself, never under 'scrollBarSideGap'.
scrollBarGap :: Float -> Float
scrollBarGap :: Float -> Float
scrollBarGap Float
trailPad = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
scrollBarSideGap Float
trailPad

-- | Space an overflowing scroller takes from its content, beside the padding
-- @trailPad@ on the bar's side, so the content stops one gap before the bar.
-- A list bar keeps a gap to its well's edge as well. A page bar sits a side
-- gap inside the page's edge. A window body's bar sits out in the window's
-- padding, a side gap inside the window's edge, so that padding is the gap
-- and only the bar and the side gap come out of the content.
scrollBarGutter :: ScrollBarSlot -> Float -> Float
scrollBarGutter :: ScrollBarSlot -> Float -> Float
scrollBarGutter ScrollBarSlot
slot Float
trailPad =
  let (Float
barW, Float
_) = ScrollBarSlot -> (Float, Float)
scrollBarGeomFor ScrollBarSlot
slot
      gap :: Float
gap = Float -> Float
scrollBarGap Float
trailPad
   in case ScrollBarSlot
slot of
        ScrollBarSlot
ScrollBarList -> Float
barW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
trailPad
        ScrollBarSlot
ScrollBarPage -> Float
barW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
scrollBarSideGap Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gap Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
trailPad
        ScrollBarSlot
ScrollBarWindow -> Float
barW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
scrollBarSideGap

scrollLayoutGutter :: ScrollBarSlot -> Float -> Float -> Float -> Float
scrollLayoutGutter :: ScrollBarSlot -> Float -> Float -> Float -> Float
scrollLayoutGutter ScrollBarSlot
slot Float
trailPad Float
contentSize Float
innerMain
  | Float
contentSize Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
innerMain = Float
0
  | Bool
otherwise = ScrollBarSlot -> Float -> Float
scrollBarGutter ScrollBarSlot
slot Float
trailPad

measureText :: FontMetrics -> Text -> (Float, Float)
measureText :: FontMetrics -> Text -> (Float, Float)
measureText FontMetrics
fm Text
txt =
  let h :: Float
h = FontMetrics -> Float
fmLineHeight FontMetrics
fm
      w :: Float
w = FontMetrics -> Text -> Float
lineWidth FontMetrics
fm Text
txt
   in (Float
w, Float
h)

-- | The one policy for "does this node use the ambient base font, or does it
-- need the host resolver?". A zero size with a plain weight/style and the
-- regular or mono variant resolves to the pre-read base metrics; everything
-- else (heading/muted/danger, bold, italic, explicit size) defers to the host.
-- Layout, paint, span placement and hit testing all share this so they cannot
-- pick different faces for the same node.
{-# INLINE isDefaultNodeFont #-}
isDefaultNodeFont :: Float -> FontWeight -> FontStyle -> FontVariant -> Bool
isDefaultNodeFont :: Float -> FontWeight -> FontStyle -> FontVariant -> Bool
isDefaultNodeFont Float
size FontWeight
weight FontStyle
style FontVariant
variant =
  Float
size Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0
    Bool -> Bool -> Bool
&& FontWeight
weight FontWeight -> FontWeight -> Bool
forall a. Eq a => a -> a -> Bool
== FontWeight
WeightNormal
    Bool -> Bool -> Bool
&& FontStyle
style FontStyle -> FontStyle -> Bool
forall a. Eq a => a -> a -> Bool
== FontStyle
FontStyleNormal
    Bool -> Bool -> Bool
&& (FontVariant
variant FontVariant -> FontVariant -> Bool
forall a. Eq a => a -> a -> Bool
== FontVariant
FontRegular Bool -> Bool -> Bool
|| FontVariant
variant FontVariant -> FontVariant -> Bool
forall a. Eq a => a -> a -> Bool
== FontVariant
FontMono)

-- | Advance of @c@ plus its kerning against the previous character: the one
-- pen step shared by measuring, hit testing and glyph emission.
{-# INLINE kernedAdvance #-}
kernedAdvance :: FontMetrics -> Maybe Char -> Char -> Float
kernedAdvance :: FontMetrics -> Maybe Char -> Char -> Float
kernedAdvance FontMetrics
fm Maybe Char
prev Char
c = case Maybe Char
prev of
  Maybe Char
Nothing -> FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
c
  Just Char
p -> FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
c Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Char -> Char -> Float
fmKerning FontMetrics
fm Char
p Char
c

-- | The character index whose caret is nearest @x@: from the shaped carets
-- when the text was prepared by a shaping host, which handles clusters and
-- right-to-left runs, and otherwise from the same advances and kerning as
-- 'NanoUI.Draw.pushText', so the caret lands where the glyph to its left was
-- drawn.
textIndexAtX :: FontMetrics -> Text -> Float -> Int
textIndexAtX :: FontMetrics -> Text -> Float -> Int
textIndexAtX FontMetrics
fm Text
txt Float
x
  | Text -> Bool
T.null Text
txt = Int
0
  | Just ShapedText
st <- FontMetrics -> Text -> Maybe ShapedText
fmShape FontMetrics
fm Text
txt =
      let carets :: PrimArray Float
carets = ShapedText -> PrimArray Float
stCarets ShapedText
st
          n :: Int
n = PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
carets
          nearest :: Int -> Float -> Int -> Int
nearest !Int
best !Float
bestD !Int
i
            | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Int
best
            | Bool
otherwise =
                let d :: Float
d = Float -> Float
forall a. Num a => a -> a
abs (PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
carets Int
i Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x)
                 in if Float
d Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
bestD then Int -> Float -> Int -> Int
nearest Int
i Float
d (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) else Int -> Float -> Int -> Int
nearest Int
best Float
bestD (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
       in Int -> Float -> Int -> Int
nearest Int
0 (Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0) Int
0
  | Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Int
0
  | Bool
otherwise = Int -> Float -> Maybe Char -> Text -> Int
go Int
0 Float
0.0 Maybe Char
forall a. Maybe a
Nothing Text
txt
  where
    go :: Int -> Float -> Maybe Char -> Text -> Int
go !Int
i !Float
acc Maybe Char
prev Text
t =
      case Text -> Maybe (Char, Text)
T.uncons Text
t of
        Maybe (Char, Text)
Nothing -> Int
i
        Just (Char
c, Text
rest) ->
          let adv :: Float
adv = FontMetrics -> Maybe Char -> Char -> Float
kernedAdvance FontMetrics
fm Maybe Char
prev Char
c
              mid :: Float
mid = Float
acc Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
adv Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.5
           in if Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
mid then Int
i else Int -> Float -> Maybe Char -> Text -> Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Float
acc Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
adv) (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c) Text
rest

-- | Where the caret before character @i@ of @txt@ sits: a shaped caret when
-- the snapshot was prepared for @txt@, else the width of the characters
-- before it.
caretX :: FontMetrics -> Text -> Int -> Float
caretX :: FontMetrics -> Text -> Int -> Float
caretX FontMetrics
fm Text
txt Int
i = case FontMetrics -> Text -> Maybe ShapedText
fmShape FontMetrics
fm Text
txt of
  Just ShapedText
st ->
    let carets :: PrimArray Float
carets = ShapedText -> PrimArray Float
stCarets ShapedText
st
     in if PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
carets Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Float
0 else PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
carets (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
carets Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
i))
  Maybe ShapedText
Nothing -> FontMetrics -> Text -> Float
lineWidth FontMetrics
fm (Int -> Text -> Text
T.take Int
i Text
txt)

caretXIO :: FontMetrics -> Text -> Int -> IO Float
caretXIO :: FontMetrics -> Text -> Int -> IO Float
caretXIO FontMetrics
fm Text
txt Int
i = do
  prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
txt
  pure $! caretX prepared txt i

-- | The horizontal extents covering characters @lo@ to @hi@: one span for
-- left-to-right text, and a span per direction run where a selection crosses
-- right-to-left text.
selectionSpans :: FontMetrics -> Text -> Int -> Int -> [(Float, Float)]
selectionSpans :: FontMetrics -> Text -> Int -> Int -> [(Float, Float)]
selectionSpans FontMetrics
fm Text
txt Int
lo Int
hi
  | Int
hi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lo = []
  | Just ShapedText
st <- FontMetrics -> Text -> Maybe ShapedText
fmShape FontMetrics
fm Text
txt =
      let carets :: PrimArray Float
carets = ShapedText -> PrimArray Float
stCarets ShapedText
st
          n :: Int
n = PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
carets Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          charSpan :: Int -> (Float, Float)
charSpan Int
i =
            let a :: Float
a = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
carets Int
i
                b :: Float
b = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
carets (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
             in (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
a Float
b, Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
a Float
b)
          merge :: [(b, b)] -> [(b, b)]
merge [] = []
          merge [(b, b)
one] = [(b, b)
one]
          merge ((b
a0, b
a1) : (b
b0, b
b1) : [(b, b)]
rest)
            | b
b0 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
a1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
0.5 Bool -> Bool -> Bool
&& b
b1 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= b
a0 b -> b -> b
forall a. Num a => a -> a -> a
- b
0.5 = [(b, b)] -> [(b, b)]
merge ((b -> b -> b
forall a. Ord a => a -> a -> a
min b
a0 b
b0, b -> b -> b
forall a. Ord a => a -> a -> a
max b
a1 b
b1) (b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
: [(b, b)]
rest)
            | Bool
otherwise = (b
a0, b
a1) (b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
: [(b, b)] -> [(b, b)]
merge ((b
b0, b
b1) (b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
: [(b, b)]
rest)
       in [(Float, Float)] -> [(Float, Float)]
forall {b}. (Ord b, Fractional b) => [(b, b)] -> [(b, b)]
merge [Int -> (Float, Float)
charSpan Int
i | Int
i <- [Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
lo .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
  | Bool
otherwise = [(FontMetrics -> Text -> Int -> Float
caretX FontMetrics
fm Text
txt Int
lo, FontMetrics -> Text -> Int -> Float
caretX FontMetrics
fm Text
txt Int
hi)]

lineWidth :: FontMetrics -> Text -> Float
lineWidth :: FontMetrics -> Text -> Float
lineWidth FontMetrics
fm Text
line
  | Text -> Bool
T.null Text
line = Float
0
  | Bool
otherwise =
      case FontMetrics -> Text -> Maybe ShapedText
fmShape FontMetrics
fm Text
line of
        Just ShapedText
st -> ShapedText -> Float
stAdvance ShapedText
st
        Maybe ShapedText
Nothing ->
          let !spaceAdv :: Float
spaceAdv = FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
' '
              !xAdv :: Float
xAdv = FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
'x'
              !mAdv :: Float
mAdv = FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
'M'
           in if Float
spaceAdv Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
xAdv Bool -> Bool -> Bool
&& Float
xAdv Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
mAdv Bool -> Bool -> Bool
&& FontMetrics -> Char -> Char -> Float
fmKerning FontMetrics
fm Char
'x' Char
'M' Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0
                then Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int
T.length Text
line) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
spaceAdv
                else case Text -> Maybe (Char, Text)
T.uncons Text
line of
                  Just (Char
c0, Text
rest) ->
                    (Float, Char) -> Float
forall a b. (a, b) -> a
fst (((Float, Char) -> Char -> (Float, Char))
-> (Float, Char) -> Text -> (Float, Char)
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (Float, Char) -> Char -> (Float, Char)
step (FontMetrics -> Char -> Float
fmAdvance FontMetrics
fm Char
c0, Char
c0) Text
rest)
                  Maybe (Char, Text)
Nothing -> Float
0
  where
    step :: (Float, Char) -> Char -> (Float, Char)
step (!Float
w, !Char
prev) Char
c = (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Maybe Char -> Char -> Float
kernedAdvance FontMetrics
fm (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
prev) Char
c, Char
c)

measureTextWrappedIO :: (Text -> IO Float) -> FontMetrics -> Text -> Float -> IO (Float, Float)
measureTextWrappedIO :: (Text -> IO Float)
-> FontMetrics -> Text -> Float -> IO (Float, Float)
measureTextWrappedIO Text -> IO Float
lineW FontMetrics
fm Text
txt Float
maxW = do
  textLines <- (Text -> IO Float) -> Text -> Float -> IO [Text]
wrapTextLinesIO Text -> IO Float
lineW Text
txt Float
maxW
  ws <- mapM lineW textLines
  let lineH = FontMetrics -> Float
fmLineHeight FontMetrics
fm
  pure $ case textLines of
    [] -> (Float
0, Float
lineH)
    [Text]
_ -> (Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
maxW ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Float]
ws), Float
lineH Float -> Float -> Float
forall a. Num a => a -> a -> a
* Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
textLines))

-- | Wrap each paragraph to @maxW@ using the host line measure: whole words
-- first, characters for words (or paragraphs) that cannot fit.
wrapTextLinesIO :: (Text -> IO Float) -> Text -> Float -> IO [Text]
wrapTextLinesIO :: (Text -> IO Float) -> Text -> Float -> IO [Text]
wrapTextLinesIO Text -> IO Float
lineW Text
txt Float
maxW = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> IO [[Text]] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO [Text]) -> [Text] -> IO [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> IO [Text]
wrapParagraph (Text -> [Text]
T.lines Text
txt)
  where
    wrapParagraph :: Text -> IO [Text]
wrapParagraph Text
para
      | Float
maxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Text -> Bool
T.null Text
para = [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
""]
      | Bool
otherwise = do
          w <- Text -> IO Float
lineW Text
para
          if w <= maxW
            then pure [para]
            else if T.any (== ' ') para
              then wrapWords (T.words para) []
              else reverse <$> charLines para []
    wrapWords :: [Text] -> [Text] -> IO [Text]
wrapWords [] [Text]
acc = [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc)
    wrapWords (Text
word : [Text]
wordsLeft) [Text]
acc = case [Text]
acc of
      [] -> Text -> [Text] -> [Text] -> IO [Text]
startLine Text
word [Text]
wordsLeft [Text]
acc
      Text
line : [Text]
rest -> do
        let candidate :: Text
candidate = Text
line Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
word
        width <- Text -> IO Float
lineW Text
candidate
        if width <= maxW
          then wrapWords wordsLeft (candidate : rest)
          else startLine word wordsLeft acc
    startLine :: Text -> [Text] -> [Text] -> IO [Text]
startLine Text
word [Text]
wordsLeft [Text]
acc = do
      width <- Text -> IO Float
lineW Text
word
      if width <= maxW
        then wrapWords wordsLeft (word : acc)
        else do
          broken <- charLines word []
          wrapWords wordsLeft (broken ++ acc)
    charLines :: Text -> [Text] -> IO [Text]
charLines Text
chunk [Text]
acc
      | Text -> Bool
T.null Text
chunk = [Text] -> IO [Text]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
acc
      | Bool
otherwise = do
          (line, rest) <- (Text -> IO Float) -> Float -> Text -> IO (Text, Text)
takeWidth Text -> IO Float
lineW Float
maxW Text
chunk
          if T.null line
            then pure acc
            else charLines rest (line : acc)

-- Always consume at least one character from non-empty text, even when a
-- single glyph exceeds the available width, so wrapping makes progress.
takeWidth :: (Text -> IO Float) -> Float -> Text -> IO (Text, Text)
takeWidth :: (Text -> IO Float) -> Float -> Text -> IO (Text, Text)
takeWidth Text -> IO Float
lineW Float
maxW Text
txt
  | Text -> Bool
T.null Text
txt = (Text, Text) -> IO (Text, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
txt, Text
T.empty)
  | Bool
otherwise = (Int -> Text -> (Text, Text)
`T.splitAt` Text
txt) (Int -> (Text, Text)) -> IO Int -> IO (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO Int
maxFit Int
1 (Text -> Int
T.length Text
txt)
  where
    maxFit :: Int -> Int -> IO Int
maxFit Int
lo Int
hi
      | Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hi = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
lo
      | Bool
otherwise = do
          let mid :: Int
mid = (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
          ok <- (Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
maxW) (Float -> Bool) -> IO Float -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Float
lineW (Int -> Text -> Text
T.take Int
mid Text
txt)
          if ok then maxFit mid hi else maxFit lo (mid - 1)

truncateTextIO :: (Text -> IO Float) -> Float -> Text -> IO Text
truncateTextIO :: (Text -> IO Float) -> Float -> Text -> IO Text
truncateTextIO Text -> IO Float
lineW Float
maxW Text
txt
  | Float
maxW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
""
  | Bool
otherwise = do
      w <- Text -> IO Float
lineW Text
txt
      if w <= maxW
        then pure txt
        else do
          ellW <- lineW "..."
          if maxW <= ellW
            then fst <$> takeWidth lineW maxW txt
            else do
              (fit, _) <- takeWidth lineW (maxW - ellW) txt
              pure (T.dropWhileEnd (== '.') fit <> "...")