{-# LANGUAGE StrictData #-}

-- | Text emitters (plain and synthetic-styled) and the 'DrawOp' interpreter.
module NanoUI.Draw.Text
  ( drawTextBox
  , pushText
  , pushTextStyled
  , emitDrawOps
  ) where

import Control.Monad (forM_, unless, when)
import Data.IORef (readIORef)
import qualified Data.Text as T
import Data.Primitive.SmallArray (SmallArray, indexSmallArray, sizeofSmallArray)
import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray)
import Data.Word (Word32, Word8)
import Foreign.Ptr (Ptr)
import NanoUI.Draw.Arena
import NanoUI.Draw.Shapes
import NanoUI.Draw.Types (DrawArena (..), DrawOp (..), TextFont (..), glyphAtlasTextureId, indexSize, vertexSize)
import NanoUI.Font
  ( FontMetrics (..)
  , GlyphQuad (..)
  , ShapedGlyphs (..)
  , drawGlyph
  , drawShaped
  , kernedAdvance
  , lineWidth
  , prepareFontMetrics
  )
import NanoUI.SIMD (pokeQuadSIMD, pokeVertexSIMD)
import NanoUI.Style (FontStyle (..), FontWeight (..), TextDecoration (..))
import NanoUI.Types (Color (..), Rect (..), onGrid)

-- | Pixel box for a 'DrawText' using host advances. diagrams text has no
-- envelope, so plot sizing uses this instead of `fontSizeL`.
drawTextBox :: FontMetrics -> Float -> Float -> Float -> Float -> T.Text -> Rect
drawTextBox :: FontMetrics -> Float -> Float -> Float -> Float -> Text -> Rect
drawTextBox FontMetrics
fm Float
x Float
y Float
ax Float
ay Text
t =
  let tw :: Float
tw = FontMetrics -> Text -> Float
lineWidth FontMetrics
fm Text
t
      th :: Float
th = FontMetrics -> Float
fmLineHeight FontMetrics
fm
      px :: Float
px = Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
tw Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
ax
      py :: Float
py =
        if Float
ay Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0
          then Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- FontMetrics -> Float
fmAscent FontMetrics
fm
          else Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
th Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ay)
   in Float -> Float -> Float -> Float -> Rect
Rect Float
px Float
py Float
tw Float
th

{-# INLINE pushText #-}
pushText :: DrawArena -> FontMetrics -> Float -> Float -> T.Text -> Color -> IO ()
pushText :: DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushText DrawArena
_da FontMetrics
_fm Float
_x Float
_y Text
txt Color
_col | Text -> Bool
T.null Text
txt = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pushText DrawArena
da FontMetrics
fm Float
x Float
y Text
txt Color
col = do
  prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
txt
  external <- readIORef (daExternalText da)
  unless external $ pushPreparedTextQuads da prepared x y txt col

{-# INLINE pushTextStyled #-}
pushTextStyled ::
  DrawArena ->
  FontMetrics ->
  FontWeight ->
  FontStyle ->
  TextDecoration ->
  Float ->
  Float ->
  T.Text ->
  Color ->
  IO ()
pushTextStyled :: DrawArena
-> FontMetrics
-> FontWeight
-> FontStyle
-> TextDecoration
-> Float
-> Float
-> Text
-> Color
-> IO ()
pushTextStyled DrawArena
da FontMetrics
fm FontWeight
weight FontStyle
fstyle TextDecoration
deco Float
x Float
y Text
txt Color
col = do
  prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
txt
  external <- readIORef (daExternalText da)
  unless external $ pushPreparedTextStyledQuads da prepared weight fstyle deco x y txt col

-- Snapping the pen to the device pixel grid keeps every glyph quad on a whole
-- pixel. Advances, bearings, and ink sizes are all integer pixel counts divided
-- by the snap scale, so snapping the origin alone aligns the whole line:
-- otherwise fractional layout positions leave glyphs straddling pixel
-- boundaries, which makes nearest-sampled atlas text blurry and jitter as
-- scroll position changes.
pushPreparedTextQuads :: DrawArena -> FontMetrics -> Float -> Float -> T.Text -> Color -> IO ()
pushPreparedTextQuads :: DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushPreparedTextQuads DrawArena
da FontMetrics
fm Float
x Float
y Text
txt Color
col = do
  let !px :: Float
px = Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) Float
x
      !py :: Float
py = Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) Float
y
  -- The host's shaped glyphs when it shapes, otherwise glyphs by character.
  FontMetrics -> Text -> IO (Maybe ShapedGlyphs)
drawShaped FontMetrics
fm Text
txt IO (Maybe ShapedGlyphs) -> (Maybe ShapedGlyphs -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ShapedGlyphs
glyphs -> DrawArena
-> FontMetrics
-> Float
-> Float
-> Float
-> ShapedGlyphs
-> Color
-> IO ()
pushShapedQuads DrawArena
da FontMetrics
fm Float
0 Float
px Float
py ShapedGlyphs
glyphs Color
col
    Maybe ShapedGlyphs
Nothing -> DrawArena
-> FontMetrics -> Float -> Float -> Float -> Text -> Color -> IO ()
pushGlyphQuads DrawArena
da FontMetrics
fm Float
0 Float
px Float
py Text
txt Color
col

-- | A shaped line's glyph quads from pen @(px, py)@, sheared by @slant@
-- around the baseline like 'pushGlyphQuads'.
pushShapedQuads :: DrawArena -> FontMetrics -> Float -> Float -> Float -> ShapedGlyphs -> Color -> IO ()
pushShapedQuads :: DrawArena
-> FontMetrics
-> Float
-> Float
-> Float
-> ShapedGlyphs
-> Color
-> IO ()
pushShapedQuads DrawArena
da FontMetrics
fm Float
slant Float
px Float
py (ShapedGlyphs PrimArray Float
quads) Color
col = do
  let !count :: Int
count = PrimArray Float -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Float
quads Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    DrawArena -> Int -> IO ()
setTexture DrawArena
da Int
glyphAtlasTextureId
    DrawArena
-> Int
-> Int
-> (Ptr Word8
    -> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ())
-> IO ()
withVertsReserve DrawArena
da (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
6) ((Ptr Word8
  -> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ())
 -> IO ())
-> (Ptr Word8
    -> Ptr Word8 -> Int -> Int -> (Int -> Int -> IO ()) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
vp Ptr Word8
ip Int
base Int
baseIdx Int -> Int -> IO ()
commit -> do
      let !(Float
r, Float
g, Float
b, Float
a) = Color -> (Float, Float, Float, Float)
unpackColorF Color
col
          !baselineY :: Float
baselineY = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
fmAscent FontMetrics
fm
          at :: Int -> Float
at Int
k = PrimArray Float -> Int -> Float
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Float
quads Int
k
          go :: Int -> IO ()
go !Int
q
            | Int
q Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
count = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise = do
                let !o :: Int
o = Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
                    !gx :: Float
gx = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
at Int
o
                    !gy :: Float
gy = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    !gw :: Float
gw = Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                    !gh :: Float
gh = Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                    !u0 :: Float
u0 = Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
                    !v0 :: Float
v0 = Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5)
                    !u1 :: Float
u1 = Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6)
                    !v1 :: Float
v1 = Int -> Float
at (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7)
                Ptr Word8
-> Ptr Word8
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeGlyphQuad Ptr Word8
vp Ptr Word8
ip Int
base Int
baseIdx Float
slant Float
baselineY Float
r Float
g Float
b Float
a Int
q Float
gx Float
gy Float
gw Float
gh Float
u0 Float
v0 Float
u1 Float
v1
                Int -> IO ()
go (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      Int -> IO ()
go Int
0
      Int -> Int -> IO ()
commit (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
6)

-- | Glyph quad @q@ of a text reservation whose vertices start at @base@ and
-- indices at @baseIdx@. A non-zero @slant@ shears the quad around
-- @baselineY@. INLINE: it runs per glyph and takes more arguments than GHC
-- unboxes for a call.
{-# INLINE pokeGlyphQuad #-}
pokeGlyphQuad ::
  Ptr Word8 ->
  Ptr Word8 ->
  Int ->
  Int ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Int ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  Float ->
  IO ()
pokeGlyphQuad :: Ptr Word8
-> Ptr Word8
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeGlyphQuad Ptr Word8
vp Ptr Word8
ip Int
base Int
baseIdx Float
slant Float
baselineY Float
r Float
g Float
b Float
a Int
q Float
gx Float
gy Float
gw Float
gh Float
u0 Float
v0 Float
u1 Float
v1 = do
  let !vb :: Int
vb = (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
vertexSize
      !ib :: Int
ib = (Int
baseIdx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
6) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
indexSize
      !i0 :: Word32
i0 = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
base Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) :: Word32
  if Float
slant Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0
    then Ptr Word8
-> Int
-> Ptr Word8
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Word32
-> IO ()
pokeQuadSIMD Ptr Word8
vp Int
vb Ptr Word8
ip Int
ib Float
gx Float
gy Float
gw Float
gh Float
u0 Float
v0 Float
u1 Float
v1 Float
r Float
g Float
b Float
a Word32
i0
    else do
      let !gy1 :: Float
gy1 = Float
gy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gh
          !topDx :: Float
topDx = Float
slant Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
baselineY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gy)
          !botDx :: Float
botDx = Float
slant Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
baselineY Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
gy1)
      Ptr Word8
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeVertexSIMD Ptr Word8
vp Int
vb (Float
gx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
topDx) Float
gy Float
r Float
g Float
b Float
a Float
u0 Float
v0
      Ptr Word8
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeVertexSIMD Ptr Word8
vp (Int
vb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32) (Float
gx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
topDx) Float
gy Float
r Float
g Float
b Float
a Float
u1 Float
v0
      Ptr Word8
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeVertexSIMD Ptr Word8
vp (Int
vb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
64) (Float
gx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
gw Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
botDx) Float
gy1 Float
r Float
g Float
b Float
a Float
u1 Float
v1
      Ptr Word8
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeVertexSIMD Ptr Word8
vp (Int
vb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
96) (Float
gx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
botDx) Float
gy1 Float
r Float
g Float
b Float
a Float
u0 Float
v1
      Ptr Word8 -> Int -> Word32 -> Word32 -> Word32 -> Word32 -> IO ()
pokeQuadIndices Ptr Word8
ip Int
ib Word32
i0 (Word32
i0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1) (Word32
i0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
2) (Word32
i0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
3)

-- | Glyph quads for one line from pen @(px, py)@, used as given: synthetic bold
-- relies on its sub-pixel pass offsets. Every quad shares one arena
-- reservation. A non-zero @slant@ shears glyphs around the shared baseline for
-- synthetic oblique, so stems stay parallel and descenders lean left. A glyph
-- the font lacks draws an upright advance box on the device grid.
pushGlyphQuads :: DrawArena -> FontMetrics -> Float -> Float -> Float -> T.Text -> Color -> IO ()
pushGlyphQuads :: DrawArena
-> FontMetrics -> Float -> Float -> Float -> Text -> Color -> IO ()
pushGlyphQuads DrawArena
da FontMetrics
fm Float
slant Float
px Float
py Text
txt Color
col = do
  let !cap :: Int
cap = Text -> Int
T.length Text
txt
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    scale <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef (DrawArena -> IORef Float
daSnapScale DrawArena
da)
    setTexture da glyphAtlasTextureId
    withVertsReserve da (cap * 4) (cap * 6) $ \Ptr Word8
vp Ptr Word8
ip Int
base Int
baseIdx Int -> Int -> IO ()
commit -> do
      let !(Float
r, Float
g, Float
b, Float
a) = Color -> (Float, Float, Float, Float)
unpackColorF Color
col
          !baselineY :: Float
baselineY = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
fmAscent FontMetrics
fm
          walk :: Int -> Float -> Maybe Char -> Text -> IO Int
walk !Int
q !Float
ox !Maybe Char
prev !Text
t =
            case Text -> Maybe (Char, Text)
T.uncons Text
t of
              Maybe (Char, Text)
Nothing -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
q
              Just (Char
c, Text
rest) -> do
                let !adv :: Float
adv = FontMetrics -> Maybe Char -> Char -> Float
kernedAdvance FontMetrics
fm Maybe Char
prev Char
c
                    next :: Int -> IO Int
next !Int
q' = Int -> Float -> Maybe Char -> Text -> IO Int
walk Int
q' (Float
ox 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
                FontMetrics -> Char -> IO (Maybe GlyphQuad)
drawGlyph FontMetrics
fm Char
c IO (Maybe GlyphQuad) -> (Maybe GlyphQuad -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Maybe GlyphQuad
Nothing
                    | Float
adv Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' -> do
                        Ptr Word8
-> Ptr Word8
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeGlyphQuad Ptr Word8
vp Ptr Word8
ip Int
base Int
baseIdx Float
0 Float
baselineY Float
r Float
g Float
b Float
a Int
q (Float -> Float -> Float
onGrid Float
scale Float
ox) (Float -> Float -> Float
onGrid Float
scale Float
py) Float
adv (FontMetrics -> Float
fmLineHeight FontMetrics
fm) Float
whitePixelU Float
whitePixelV Float
whitePixelU Float
whitePixelV
                        Int -> IO Int
next (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    | Bool
otherwise -> Int -> IO Int
next Int
q
                  Just GlyphQuad
gq -> do
                    Ptr Word8
-> Ptr Word8
-> Int
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Int
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> IO ()
pokeGlyphQuad Ptr Word8
vp Ptr Word8
ip Int
base Int
baseIdx Float
slant Float
baselineY Float
r Float
g Float
b Float
a Int
q (Float
ox Float -> Float -> Float
forall a. Num a => a -> a -> a
+ GlyphQuad -> Float
gqX GlyphQuad
gq) (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ GlyphQuad -> Float
gqY GlyphQuad
gq) (GlyphQuad -> Float
gqW GlyphQuad
gq) (GlyphQuad -> Float
gqH GlyphQuad
gq) (GlyphQuad -> Float
gqU0 GlyphQuad
gq) (GlyphQuad -> Float
gqV0 GlyphQuad
gq) (GlyphQuad -> Float
gqU1 GlyphQuad
gq) (GlyphQuad -> Float
gqV1 GlyphQuad
gq)
                    Int -> IO Int
next (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      !k <- Int -> Float -> Maybe Char -> Text -> IO Int
walk Int
0 Float
px Maybe Char
forall a. Maybe a
Nothing Text
txt
      commit (k * 4) (k * 6)

-- | Synthetic weight, slant and decoration over the plain text path. Upright
-- normal weight keeps the run path; every other pass walks glyphs.
pushPreparedTextStyledQuads :: DrawArena -> FontMetrics -> FontWeight -> FontStyle -> TextDecoration -> Float -> Float -> T.Text -> Color -> IO ()
pushPreparedTextStyledQuads :: DrawArena
-> FontMetrics
-> FontWeight
-> FontStyle
-> TextDecoration
-> Float
-> Float
-> Text
-> Color
-> IO ()
pushPreparedTextStyledQuads DrawArena
da FontMetrics
fm FontWeight
weight FontStyle
fstyle TextDecoration
deco Float
x Float
y Text
txt Color
col
  | FontWeight
weight FontWeight -> FontWeight -> Bool
forall a. Eq a => a -> a -> Bool
== FontWeight
WeightNormal Bool -> Bool -> Bool
&& FontStyle
fstyle FontStyle -> FontStyle -> Bool
forall a. Eq a => a -> a -> Bool
== FontStyle
FontStyleNormal Bool -> Bool -> Bool
&& TextDecoration
deco TextDecoration -> TextDecoration -> Bool
forall a. Eq a => a -> a -> Bool
== TextDecoration
DecorationNone =
      DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushPreparedTextQuads DrawArena
da FontMetrics
fm Float
x Float
y Text
txt Color
col
  | Bool
otherwise = do
      let !px :: Float
px = Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) Float
x
          !py :: Float
py = Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) Float
y
          !lh :: Float
lh = FontMetrics -> Float
fmLineHeight FontMetrics
fm
          !bOff :: Float
bOff = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.0 (Float
0.05 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lh)
          !slant :: Float
slant = if FontStyle
fstyle FontStyle -> FontStyle -> Bool
forall a. Eq a => a -> a -> Bool
== FontStyle
FontStyleNormal then Float
0 else Float
0.18
          -- Pen offsets, in bold steps, of the passes that synthesize a weight.
          passes :: [Float]
passes = case FontWeight
weight of
            FontWeight
WeightNormal -> [Float
0]
            FontWeight
WeightLight -> [Float
0]
            FontWeight
WeightMedium -> [Float
0, Float
0.5]
            FontWeight
WeightSemiBold -> [Float
0, Float
0.75]
            FontWeight
WeightBold -> [Float
0, Float
1]
            FontWeight
WeightExtraBold -> [Float
0, Float
1, Float
1.5]
            FontWeight
WeightBlack -> [Float
0, Float
1, Float
1.5, Float
2]
      if Float
slant Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 Bool -> Bool -> Bool
&& FontWeight
weight FontWeight -> FontWeight -> Bool
forall a. Eq a => a -> a -> Bool
== FontWeight
WeightNormal
        then DrawArena
-> FontMetrics -> Float -> Float -> Text -> Color -> IO ()
pushPreparedTextQuads DrawArena
da FontMetrics
fm Float
px Float
py Text
txt Color
col
        else do
          shaped <- FontMetrics -> Text -> IO (Maybe ShapedGlyphs)
drawShaped FontMetrics
fm Text
txt
          forM_ passes $ \Float
k -> case Maybe ShapedGlyphs
shaped of
            Just ShapedGlyphs
glyphs -> DrawArena
-> FontMetrics
-> Float
-> Float
-> Float
-> ShapedGlyphs
-> Color
-> IO ()
pushShapedQuads DrawArena
da FontMetrics
fm Float
slant (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
k Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
bOff) Float
py ShapedGlyphs
glyphs Color
col
            Maybe ShapedGlyphs
Nothing -> DrawArena
-> FontMetrics -> Float -> Float -> Float -> Text -> Color -> IO ()
pushGlyphQuads DrawArena
da FontMetrics
fm Float
slant (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
k Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
bOff) Float
py Text
txt Color
col
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TextDecoration
deco TextDecoration -> TextDecoration -> Bool
forall a. Eq a => a -> a -> Bool
/= TextDecoration
DecorationNone) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let !textW :: Float
textW = FontMetrics -> Text -> Float
lineWidth FontMetrics
fm Text
txt
            !thick :: Float
thick = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.0 (Float
0.06 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lh)
            underline :: IO ()
underline = DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
px (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
fmAscent FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1.0 (Float
0.1 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lh)) Float
textW Float
thick) Color
col
            strike :: IO ()
strike = DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da (Float -> Float -> Float -> Float -> Rect
Rect Float
px (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ FontMetrics -> Float
fmAscent FontMetrics
fm Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.65) Float
textW Float
thick) Color
col
        case TextDecoration
deco of
          TextDecoration
DecorationUnderline -> IO ()
underline
          TextDecoration
DecorationStrikethrough -> IO ()
strike
          TextDecoration
DecorationUnderlineStrike -> IO ()
underline IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
strike
          TextDecoration
DecorationNone -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Emit ops with @fm@ as the default font and @resolve@ giving the font of
-- styled text, and whether it draws its weight and slant natively.
emitDrawOps :: DrawArena -> FontMetrics -> (TextFont -> IO (FontMetrics, Bool)) -> SmallArray DrawOp -> IO ()
emitDrawOps :: DrawArena
-> FontMetrics
-> (TextFont -> IO (FontMetrics, Bool))
-> SmallArray DrawOp
-> IO ()
emitDrawOps DrawArena
da FontMetrics
fm TextFont -> IO (FontMetrics, Bool)
resolve SmallArray DrawOp
ops = Int -> IO ()
go Int
0
  where
    go :: Int -> IO ()
go !Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= SmallArray DrawOp -> Int
forall a. SmallArray a -> Int
sizeofSmallArray SmallArray DrawOp
ops = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = DrawOp -> IO ()
emitOne (SmallArray DrawOp -> Int -> DrawOp
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray DrawOp
ops Int
i) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    emitOne :: DrawOp -> IO ()
emitOne (FillRect Rect
r Color
c) = DrawArena -> Rect -> Color -> IO ()
pushRect DrawArena
da Rect
r Color
c
    emitOne (FillRoundedRect Rect
r Float
radius Color
c) = DrawArena -> Rect -> Float -> Color -> IO ()
pushRoundedRect DrawArena
da Rect
r Float
radius Color
c
    emitOne (FillTriangle Float
x0 Float
y0 Float
x1 Float
y1 Float
x2 Float
y2 Color
c) = DrawArena
-> Float
-> Float
-> Float
-> Float
-> Float
-> Float
-> Color
-> IO ()
pushFilledTriangle DrawArena
da Float
x0 Float
y0 Float
x1 Float
y1 Float
x2 Float
y2 Color
c
    emitOne (FillCircle Float
cx Float
cy Float
radius Color
c) = DrawArena -> Float -> Float -> Float -> Color -> IO ()
pushCircle DrawArena
da Float
cx Float
cy Float
radius Color
c
    emitOne (Stroke Float
x0 Float
y0 Float
x1 Float
y1 Float
t Color
c) = DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushStroke DrawArena
da Float
x0 Float
y0 Float
x1 Float
y1 Float
t Color
c
    emitOne (StrokeRoundedRect Rect
r Float
radius Float
bw Color
c) = DrawArena -> Rect -> Float -> Float -> Color -> IO ()
pushRoundedStroke DrawArena
da Rect
r Float
radius Float
bw Color
c
    emitOne (StrokeCircle Float
cx Float
cy Float
radius Float
bw Color
c) = DrawArena -> Float -> Float -> Float -> Float -> Color -> IO ()
pushCircleStroke DrawArena
da Float
cx Float
cy Float
radius Float
bw Color
c
    emitOne (StrokeLineAA Float
x0 Float
y0 Float
x1 Float
y1 Float
bw Color
c) = DrawArena
-> Float -> Float -> Float -> Float -> Float -> Color -> IO ()
pushStrokeAA DrawArena
da Float
x0 Float
y0 Float
x1 Float
y1 Float
bw Color
c
    emitOne (FillQuadGradient Rect
r Color
c0 Color
c1 Color
c2 Color
c3) = DrawArena -> Rect -> Color -> Color -> Color -> Color -> IO ()
pushQuadGradient DrawArena
da Rect
r Color
c0 Color
c1 Color
c2 Color
c3
    emitOne (DrawImageRect Rect
r Int
tex Float
u0 Float
v0 Float
u1 Float
v1 Color
c) = DrawArena
-> Rect
-> Int
-> Float
-> Float
-> Float
-> Float
-> Color
-> IO ()
pushImage DrawArena
da Rect
r Int
tex Float
u0 Float
v0 Float
u1 Float
v1 Color
c
    emitOne (DrawText Float
x Float
y Float
ax Float
ay Text
t Color
c) = do
      prepared <- FontMetrics -> Text -> IO FontMetrics
prepareFontMetrics FontMetrics
fm Text
t
      let Rect px py _ _ = drawTextBox prepared x y ax ay t
      -- Drawing text has no collected text span, so it keeps its quads even
      -- when the host rasterizes widget text externally.
      pushPreparedTextQuads da prepared px py t c
    emitOne (DrawTextStyled Float
x Float
y TextFont
font Text
t Color
c) = do
      (styledFm, native) <- TextFont -> IO (FontMetrics, Bool)
resolve TextFont
font
      let weight = if Bool
native then FontWeight
WeightNormal else TextFont -> FontWeight
textFontWeight TextFont
font
          fstyle = if Bool
native then FontStyle
FontStyleNormal else TextFont -> FontStyle
textFontStyle TextFont
font
      prepared <- prepareFontMetrics styledFm t
      pushPreparedTextStyledQuads da prepared weight fstyle (textFontDecoration font) x y t c