-- | Paragraphs of mixed-style text and links.
module NanoUI.Widgets.RichText
  ( Inline
  , inlineText
  , inlineWith
  , restyle
  , strong
  , emphasis
  , inlineCode
  , hyperlink
  , richText
  , richText'
  , richTextWith
  , richTextWith'
  ) where

import Control.Monad (unless)
import Data.Hashable (hashWithSalt)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.IntMap.Strict qualified as IM
import Data.List (dropWhileEnd, groupBy)
import Data.Maybe (fromMaybe, isJust)
import Data.Primitive.SmallArray (SmallArray, indexSmallArray, smallArrayFromList)
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text qualified as T
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , askHostIO
  , intKey
  , setHost
  , registerCustomCursor
  , registerCustomDrawing
  , registerCustomMeasure
  )
import NanoUI.Draw (DrawOp (..), TextFont (..))
import NanoUI.Font (FontMetrics (..), lineWidthIO)
import NanoUI.Frame.Node (resolveTextFont)
import NanoUI.Input (Input (..), UiCursorKind (..))
import NanoUI.Layout.Arena (NodeType (NodeDrawing))
import NanoUI.Monad (Ui, askContext, askDefaultLayout, askInput, nextId, uiIO, uiTheme)
import NanoUI.Style
  ( FontVariant (..)
  , Layout (..)
  , TextDecoration (..)
  , Theme (..)
  , fontBold
  , fontItalic
  , fontMono
  , styleFg
  )
import NanoUI.Types (Color (..), Rect (..), V2 (..))
import NanoUI.Widgets.Node (Response, addWidget, respClicked, respHovered, respRect)

-- | A piece of a paragraph: text in one style, and the hyperlink it follows when
-- it is one. A string literal is 'plain' text.
data Inline = Inline !Text (Layout -> Layout) !(Maybe Text)

instance IsString Inline where
  fromString :: String -> Inline
fromString = Text -> Inline
inlineText (Text -> Inline) -> (String -> Text) -> String -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

-- | Text in the paragraph's own style.
inlineText :: Text -> Inline
inlineText :: Text -> Inline
inlineText Text
txt = Text -> (Layout -> Layout) -> Maybe Text -> Inline
Inline Text
txt Layout -> Layout
forall a. a -> a
id Maybe Text
forall a. Maybe a
Nothing

-- | Text styled by font modifiers (@fontBold@, @fontSize 20@,
-- @fontColor red . fontUnderline@), applied over the paragraph's layout.
inlineWith :: (Layout -> Layout) -> Text -> Inline
inlineWith :: (Layout -> Layout) -> Text -> Inline
inlineWith Layout -> Layout
f Text
txt = Text -> (Layout -> Layout) -> Maybe Text -> Inline
Inline Text
txt Layout -> Layout
f Maybe Text
forall a. Maybe a
Nothing

-- | Add font modifiers to a piece, a hyperlink included.
restyle :: (Layout -> Layout) -> Inline -> Inline
restyle :: (Layout -> Layout) -> Inline -> Inline
restyle Layout -> Layout
f (Inline Text
txt Layout -> Layout
style Maybe Text
target) = Text -> (Layout -> Layout) -> Maybe Text -> Inline
Inline Text
txt (Layout -> Layout
f (Layout -> Layout) -> (Layout -> Layout) -> Layout -> Layout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Layout
style) Maybe Text
target

-- | Bold text.
strong :: Text -> Inline
strong :: Text -> Inline
strong = (Layout -> Layout) -> Text -> Inline
inlineWith Layout -> Layout
fontBold

-- | Italic text.
emphasis :: Text -> Inline
emphasis :: Text -> Inline
emphasis = (Layout -> Layout) -> Text -> Inline
inlineWith Layout -> Layout
fontItalic

-- | Monospaced text.
inlineCode :: Text -> Inline
inlineCode :: Text -> Inline
inlineCode = (Layout -> Layout) -> Text -> Inline
inlineWith Layout -> Layout
fontMono

-- | @hyperlink target label@: text in the theme's link colour, underlined while
-- hovered, whose click the paragraph reports as @target@.
hyperlink :: Text -> Text -> Inline
hyperlink :: Text -> Text -> Inline
hyperlink Text
target Text
label = Text -> (Layout -> Layout) -> Maybe Text -> Inline
Inline Text
label Layout -> Layout
forall a. a -> a
id (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
target)

-- | A paragraph of pieces, wrapped at its width. Returns the target of the
-- hyperlink clicked this frame.
richText :: Ui :> es => [Inline] -> Eff es (Maybe Text)
richText :: forall (es :: [Effect]).
(Ui :> es) =>
[Inline] -> Eff es (Maybe Text)
richText = (Layout -> Layout) -> [Inline] -> Eff es (Maybe Text)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> [Inline] -> Eff es (Maybe Text)
richTextWith Layout -> Layout
forall a. a -> a
id

-- | 'richText' with a layout modifier, whose font choices are the default
-- for every piece.
richTextWith :: Ui :> es => (Layout -> Layout) -> [Inline] -> Eff es (Maybe Text)
richTextWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> [Inline] -> Eff es (Maybe Text)
richTextWith Layout -> Layout
f [Inline]
pieces = (Response, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
snd ((Response, Maybe Text) -> Maybe Text)
-> Eff es (Response, Maybe Text) -> Eff es (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)
richTextWith' Layout -> Layout
f [Inline]
pieces

richText' :: Ui :> es => [Inline] -> Eff es (Response, Maybe Text)
richText' :: forall (es :: [Effect]).
(Ui :> es) =>
[Inline] -> Eff es (Response, Maybe Text)
richText' = (Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)
richTextWith' Layout -> Layout
forall a. a -> a
id

-- A resolved piece: its font, colour, line metrics and hyperlink.
data Run = Run
  { Run -> TextFont
runFont :: !TextFont
  , Run -> Color
runColor :: !Color
  , Run -> Float
runLineHeight :: !Float
  , Run -> Float
runAscent :: !Float
  , Run -> Maybe Text
runTarget :: !(Maybe Text)
  }

data TokenKind = Word | Space | Break
  deriving (TokenKind -> TokenKind -> Bool
(TokenKind -> TokenKind -> Bool)
-> (TokenKind -> TokenKind -> Bool) -> Eq TokenKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenKind -> TokenKind -> Bool
== :: TokenKind -> TokenKind -> Bool
$c/= :: TokenKind -> TokenKind -> Bool
/= :: TokenKind -> TokenKind -> Bool
Eq)

-- A word, a run of spaces or a line break, with its width in its piece's font.
data Token = Token
  { Token -> Text
_tokenText :: !Text
  , Token -> Int
tokenRun :: !Int
  , Token -> TokenKind
tokenKind :: !TokenKind
  , Token -> Float
tokenWidth :: !Float
  }

-- A laid-out line: its top, height and baseline offset, and its tokens with
-- their x positions.
data Line = Line
  { Line -> Float
lineTop :: !Float
  , Line -> Float
lineHeight :: !Float
  , Line -> Float
lineAscent :: !Float
  , Line -> Float
lineWidth :: !Float
  , Line -> [(Float, Token)]
lineTokens :: ![(Float, Token)]
  }

-- A paragraph's measured pieces and its lines at the width it last had,
-- kept between frames while its pieces, fonts and colours stay the same.
data Paragraph = Paragraph
  { Paragraph -> Int
paraKey :: !Int
  , Paragraph -> SmallArray Run
paraRuns :: !(SmallArray Run)
  , Paragraph -> [Token]
paraTokens :: ![Token]
  , Paragraph -> (Float, Float)
paraEmptyLine :: !(Float, Float)
  , Paragraph -> (Float, Float)
paraNatural :: (Float, Float)
  , Paragraph -> Float
paraWidth :: !Float
  , Paragraph -> [Line]
paraLines :: [Line]
  }

newtype Paragraphs = Paragraphs (IORef (IM.IntMap Paragraph))

richTextWith' :: Ui :> es => (Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)
richTextWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> [Inline] -> Eff es (Response, Maybe Text)
richTextWith' Layout -> Layout
f [Inline]
pieces = do
  ctx <- Eff es Context
forall (es :: [Effect]). (Ui :> es) => Eff es Context
askContext
  inp <- askInput
  base <- f <$> askDefaultLayout
  theme <- uiTheme
  wid <- nextId
  let styled = [(Text
txt, Layout -> TextFont
pieceFont Layout
l, Theme -> Layout -> Maybe Text -> Color
pieceColor Theme
theme Layout
l Maybe Text
target, Maybe Text
target) | Inline Text
txt Layout -> Layout
style Maybe Text
target <- [Inline]
pieces, let l :: Layout
l = Layout -> Layout
style Layout
base]
  cacheRef <-
    uiIO $
      askHostIO ctx >>= \case
        Just (Paragraphs IORef (IntMap Paragraph)
ref) -> IORef (IntMap Paragraph) -> IO (IORef (IntMap Paragraph))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IORef (IntMap Paragraph)
ref
        Maybe Paragraphs
Nothing -> do
          ref <- IntMap Paragraph -> IO (IORef (IntMap Paragraph))
forall a. a -> IO (IORef a)
newIORef IntMap Paragraph
forall a. IntMap a
IM.empty
          setHost ctx (Paragraphs ref)
          pure ref
  gen <- uiIO (readIORef (ctxMetricGen ctx))
  let key =
        (Int -> (Text, TextFont, Color, Maybe Text) -> Int)
-> Int -> [(Text, TextFont, Color, Maybe Text)] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
          ( \Int
h (Text
txt, TextFont Float
size FontVariant
variant FontWeight
weight FontStyle
fstyle TextDecoration
deco, Color Word32
rgba, Maybe Text
target) ->
              Int
h Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
txt Int -> Float -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Float
size Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` FontVariant -> Int
forall a. Enum a => a -> Int
fromEnum FontVariant
variant
                Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` FontWeight -> Int
forall a. Enum a => a -> Int
fromEnum FontWeight
weight Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` FontStyle -> Int
forall a. Enum a => a -> Int
fromEnum FontStyle
fstyle Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` TextDecoration -> Int
forall a. Enum a => a -> Int
fromEnum TextDecoration
deco
                Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
rgba Int -> Maybe Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Maybe Text
target
          )
          Int
gen
          [(Text, TextFont, Color, Maybe Text)]
styled
  cached <- uiIO (IM.lookup (intKey wid) <$> readIORef cacheRef)
  para0 <- case cached of
    Just Paragraph
para | Paragraph -> Int
paraKey Paragraph
para Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
key -> Paragraph -> Eff es Paragraph
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Paragraph
para
    Maybe Paragraph
_ -> IO Paragraph -> Eff es Paragraph
forall (es :: [Effect]) a. (Ui :> es) => IO a -> Eff es a
uiIO (IO Paragraph -> Eff es Paragraph)
-> IO Paragraph -> Eff es Paragraph
forall a b. (a -> b) -> a -> b
$ do
      resolved <- ((Int, (Text, TextFont, Color, Maybe Text)) -> IO (Run, [Token]))
-> [(Int, (Text, TextFont, Color, Maybe Text))]
-> IO [(Run, [Token])]
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 (Context
-> (Int, (Text, TextFont, Color, Maybe Text)) -> IO (Run, [Token])
measurePiece Context
ctx) ([Int]
-> [(Text, TextFont, Color, Maybe Text)]
-> [(Int, (Text, TextFont, Color, Maybe Text))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [(Text, TextFont, Color, Maybe Text)]
styled)
      let runs = [Run] -> SmallArray Run
forall a. [a] -> SmallArray a
smallArrayFromList (((Run, [Token]) -> Run) -> [(Run, [Token])] -> [Run]
forall a b. (a -> b) -> [a] -> [b]
map (Run, [Token]) -> Run
forall a b. (a, b) -> a
fst [(Run, [Token])]
resolved)
          tokens = ((Run, [Token]) -> [Token]) -> [(Run, [Token])] -> [Token]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Run, [Token]) -> [Token]
forall a b. (a, b) -> b
snd [(Run, [Token])]
resolved
          emptyLine = case [(Run, [Token])]
resolved of
            (Run
run, [Token]
_) : [(Run, [Token])]
_ -> (Run -> Float
runLineHeight Run
run, Run -> Float
runAscent Run
run)
            [] -> (FontMetrics -> Float
fmLineHeight (Context -> FontMetrics
ctxFontMetrics Context
ctx), FontMetrics -> Float
fmAscent (Context -> FontMetrics
ctxFontMetrics Context
ctx))
      pure (Paragraph key runs tokens emptyLine (lineBoxes (layoutLines runs emptyLine 1e9 tokens)) (-1) [])
  resp <- addWidget wid NodeDrawing T.empty 0 base
  let Rect rx ry rw _ = respRect resp
      runs = Paragraph -> SmallArray Run
paraRuns Paragraph
para0
      layoutAt Float
width = SmallArray Run -> (Float, Float) -> Float -> [Token] -> [Line]
layoutLines SmallArray Run
runs (Paragraph -> (Float, Float)
paraEmptyLine Paragraph
para0) Float
width (Paragraph -> [Token]
paraTokens Paragraph
para0)
      para
        | Paragraph -> Float
paraWidth Paragraph
para0 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
rw = Paragraph
para0
        | Bool
otherwise = Paragraph
para0 {paraWidth = rw, paraLines = layoutAt rw}
      linesAt Float
width
        | Float
width Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Paragraph -> Float
paraWidth Paragraph
para = Paragraph -> [Line]
paraLines Paragraph
para
        | Bool
otherwise = Float -> [Line]
layoutAt Float
width
      V2 mx my = inputMousePos inp
      hoveredRun
        | Bool -> Bool
not (Response -> Bool
forall r. HasResponse r => r -> Bool
respHovered Response
resp) = Maybe Int
forall a. Maybe a
Nothing
        | Bool
otherwise =
            case [ Token -> Int
tokenRun Token
tok
                 | Line
line <- Paragraph -> [Line]
paraLines Paragraph
para
                 , Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineTop Line
line Bool -> Bool -> Bool
&& Float
my Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineTop Line
line Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineHeight Line
line
                 , (Float
x, Token
tok) <- Line -> [(Float, Token)]
lineTokens Line
line
                 , Token -> TokenKind
tokenKind Token
tok TokenKind -> TokenKind -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenKind
Break
                 , Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x Bool -> Bool -> Bool
&& Float
mx Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Token -> Float
tokenWidth Token
tok
                 , Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Run -> Maybe Text
runTarget (SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs (Token -> Int
tokenRun Token
tok)))
                 ] of
              Int
run : [Int]
_ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
run
              [] -> Maybe Int
forall a. Maybe a
Nothing
      -- Words are drawn one by one, so a decoration is drawn once across a
      -- piece's words on a line and the spaces between them.
      draw CustomDrawContext
_cdc (Rect Float
x0 Float
y0 Float
w Float
_) =
        [DrawOp] -> SmallArray DrawOp
forall a. [a] -> SmallArray a
smallArrayFromList ([DrawOp] -> SmallArray DrawOp) -> [DrawOp] -> SmallArray DrawOp
forall a b. (a -> b) -> a -> b
$
          [[DrawOp]] -> [DrawOp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [ Float -> Float -> TextFont -> Text -> Color -> DrawOp
DrawTextStyled (Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x) (Line -> Run -> Float
lineY Line
line Run
run) ((Run -> TextFont
runFont Run
run) {textFontDecoration = DecorationNone}) Text
txt (Run -> Color
runColor Run
run)
              | (Float
x, Token Text
txt Int
runIdx TokenKind
Word Float
_) <- Line -> [(Float, Token)]
lineTokens Line
line
              , let run :: Run
run = SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs Int
runIdx
              ]
                [DrawOp] -> [DrawOp] -> [DrawOp]
forall a. [a] -> [a] -> [a]
++ [[DrawOp]] -> [DrawOp]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  [ [Rect -> Color -> DrawOp
FillRect (Float -> Float -> Float -> Float -> Rect
Rect (Float
x0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
x1) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
offset) (Float
x2 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
x1) Float
thick) (Run -> Color
runColor Run
run) | Float
offset <- TextDecoration -> Run -> [Float]
decorationOffsets TextDecoration
deco Run
run]
                  | [(Float, Token)]
group <- ((Float, Token) -> (Float, Token) -> Bool)
-> [(Float, Token)] -> [[(Float, Token)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(Float
_, Token
a) (Float
_, Token
b) -> Token -> Int
tokenRun Token
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Token -> Int
tokenRun Token
b) (Line -> [(Float, Token)]
lineTokens Line
line)
                  , let trimmed :: [(Float, Token)]
trimmed = ((Float, Token) -> Bool) -> [(Float, Token)] -> [(Float, Token)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Float, Token) -> Bool
forall {a}. (a, Token) -> Bool
isSpaceToken (((Float, Token) -> Bool) -> [(Float, Token)] -> [(Float, Token)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Float, Token) -> Bool
forall {a}. (a, Token) -> Bool
isSpaceToken [(Float, Token)]
group)
                  , (Float
x1, Token
first) : [(Float, Token)]
_ <- [[(Float, Token)]
trimmed]
                  , let runIdx :: Int
runIdx = Token -> Int
tokenRun Token
first
                        run :: Run
run = SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs Int
runIdx
                        deco :: TextDecoration
deco = Int -> TextDecoration
decorationOf Int
runIdx
                        (Float
lastX, Token
lastTok) = [(Float, Token)] -> (Float, Token)
forall a. HasCallStack => [a] -> a
last [(Float, Token)]
trimmed
                        x2 :: Float
x2 = Float
lastX Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Token -> Float
tokenWidth Token
lastTok
                        y :: Float
y = Line -> Run -> Float
lineY Line
line Run
run
                        thick :: Float
thick = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (Float
0.06 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Run -> Float
runLineHeight Run
run)
                  , TextDecoration
deco TextDecoration -> TextDecoration -> Bool
forall a. Eq a => a -> a -> Bool
/= TextDecoration
DecorationNone
                  ]
            | Line
line <- Float -> [Line]
linesAt Float
w
            ]
        where
          lineY :: Line -> Run -> Float
lineY Line
line Run
run = Float
y0 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineTop Line
line Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineAscent Line
line Float -> Float -> Float
forall a. Num a => a -> a -> a
- Run -> Float
runAscent Run
run
          isSpaceToken :: (a, Token) -> Bool
isSpaceToken (a
_, Token
tok) = Token -> TokenKind
tokenKind Token
tok TokenKind -> TokenKind -> Bool
forall a. Eq a => a -> a -> Bool
== TokenKind
Space
      decorationOf Int
runIdx
        | Int -> Maybe Int
forall a. a -> Maybe a
Just Int
runIdx Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
hoveredRun = TextDecoration -> TextDecoration
underlined (TextFont -> TextDecoration
textFontDecoration (Run -> TextFont
runFont (SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs Int
runIdx)))
        | Bool
otherwise = TextFont -> TextDecoration
textFontDecoration (Run -> TextFont
runFont (SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs Int
runIdx))
      -- Where underline and strikethrough sit below a line box's top, as
      -- styled labels draw them.
      decorationOffsets TextDecoration
deco Run
run =
        let lh :: Float
lh = Run -> Float
runLineHeight Run
run
            under :: Float
under = Run -> Float
runAscent Run
run Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 (Float
0.1 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lh)
            strike :: Float
strike = Run -> Float
runAscent Run
run Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
0.65
         in case TextDecoration
deco of
              TextDecoration
DecorationUnderline -> [Float
under]
              TextDecoration
DecorationStrikethrough -> [Float
strike]
              TextDecoration
DecorationUnderlineStrike -> [Float
under, Float
strike]
              TextDecoration
DecorationNone -> []
      drawKey = Int
key Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (-Int
1) Maybe Int
hoveredRun
  uiIO $ do
    unless (paraWidth para0 == rw && fmap paraKey cached == Just key) $
      modifyIORef' cacheRef $ \IntMap Paragraph
m ->
        -- Paragraphs no longer drawn are dropped all at once past a bound.
        Int -> Paragraph -> IntMap Paragraph -> IntMap Paragraph
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (WidgetId -> Int
intKey WidgetId
wid) Paragraph
para (if IntMap Paragraph -> Int
forall a. IntMap a -> Int
IM.size IntMap Paragraph
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4096 then IntMap Paragraph
forall a. IntMap a
IM.empty else IntMap Paragraph
m)
    registerCustomMeasure ctx wid $ \FontMetrics
_ (Float
availW, Float
_) ->
      if Float
availW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
1e9 then Paragraph -> (Float, Float)
paraNatural Paragraph
para else [Line] -> (Float, Float)
lineBoxes (Float -> [Line]
linesAt Float
availW)
    registerCustomDrawing ctx wid (if drawKey == 0 then 1 else drawKey) draw
    registerCustomCursor ctx wid (const (if isJust hoveredRun then UiCursorPointer else UiCursorDefault))
  let clicked
        | Response -> Bool
forall r. HasResponse r => r -> Bool
respClicked Response
resp = Maybe Int
hoveredRun Maybe Int -> (Int -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Run -> Maybe Text
runTarget (Run -> Maybe Text) -> (Int -> Run) -> Int -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs
        | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
  pure (resp, clicked)
  where
    underlined :: TextDecoration -> TextDecoration
underlined TextDecoration
DecorationStrikethrough = TextDecoration
DecorationUnderlineStrike
    underlined TextDecoration
DecorationNone = TextDecoration
DecorationUnderline
    underlined TextDecoration
deco = TextDecoration
deco
    lineBoxes :: [Line] -> (Float, Float)
lineBoxes [Line]
lines' = ([Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Float
0 Float -> [Float] -> [Float]
forall a. a -> [a] -> [a]
: (Line -> Float) -> [Line] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Float
lineWidth [Line]
lines'), [Float] -> Float
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Line -> Float) -> [Line] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Float
lineHeight [Line]
lines'))

-- | The font a piece's layout chooses.
pieceFont :: Layout -> TextFont
pieceFont :: Layout -> TextFont
pieceFont Layout
l = Float
-> FontVariant
-> FontWeight
-> FontStyle
-> TextDecoration
-> TextFont
TextFont (Layout -> Float
layoutFontSize Layout
l) (Layout -> FontVariant
layoutFontVariant Layout
l) (Layout -> FontWeight
layoutFontWeight Layout
l) (Layout -> FontStyle
layoutFontStyle Layout
l) (Layout -> TextDecoration
layoutTextDecoration Layout
l)

-- | A piece's colour: its own, else the link colour for a link, else its
-- font variant's colour.
pieceColor :: Theme -> Layout -> Maybe Text -> Color
pieceColor :: Theme -> Layout -> Maybe Text -> Color
pieceColor Theme
theme Layout
l Maybe Text
target =
  let variantColor :: Color
variantColor = case Layout -> FontVariant
layoutFontVariant Layout
l of
        FontVariant
FontHeading -> Theme -> Color
themeAccent Theme
theme
        FontVariant
FontMuted -> Theme -> Color
themeMuted Theme
theme
        FontVariant
FontDanger -> Theme -> Color
themeRed Theme
theme
        FontVariant
_ -> Style -> Color
styleFg (Theme -> Style
themePanel Theme
theme)
   in Color -> Maybe Color -> Color
forall a. a -> Maybe a -> a
fromMaybe (Color -> (Text -> Color) -> Maybe Text -> Color
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Color
variantColor (Color -> Text -> Color
forall a b. a -> b -> a
const (Theme -> Color
themeLink Theme
theme)) Maybe Text
target) (Layout -> Maybe Color
layoutFontColor Layout
l)

-- | A piece's line metrics and its tokens measured in its font.
measurePiece :: Context -> (Int, (Text, TextFont, Color, Maybe Text)) -> IO (Run, [Token])
measurePiece :: Context
-> (Int, (Text, TextFont, Color, Maybe Text)) -> IO (Run, [Token])
measurePiece Context
ctx (Int
i, (Text
txt, TextFont
font, Color
color, Maybe Text
target)) = do
  (fm, _) <- Context -> TextFont -> IO (FontMetrics, Bool)
resolveTextFont Context
ctx TextFont
font
  tokens <- mapM (measure fm) (T.groupBy (\Char
a Char
b -> Char -> TokenKind
kindOf Char
a TokenKind -> TokenKind -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> TokenKind
kindOf Char
b Bool -> Bool -> Bool
&& Char -> TokenKind
kindOf Char
a TokenKind -> TokenKind -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenKind
Break) txt)
  pure (Run font color (fmLineHeight fm) (fmAscent fm) target, tokens)
  where
    kindOf :: Char -> TokenKind
kindOf Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = TokenKind
Break
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' = TokenKind
Space
      | Bool
otherwise = TokenKind
Word
    measure :: FontMetrics -> Text -> IO Token
measure FontMetrics
fm Text
part = do
      let kind :: TokenKind
kind = Char -> TokenKind
kindOf (HasCallStack => Text -> Char
Text -> Char
T.head Text
part)
      w <- if TokenKind
kind TokenKind -> TokenKind -> Bool
forall a. Eq a => a -> a -> Bool
== TokenKind
Break then Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0 else FontMetrics -> Text -> IO Float
lineWidthIO FontMetrics
fm Text
part
      pure (Token part i kind w)

-- | Greedy lines at @width@: a break goes between words only at spaces or
-- line breaks, spaces at a wrap are dropped, and a word wider than the line
-- takes a line of its own.
layoutLines :: SmallArray Run -> (Float, Float) -> Float -> [Token] -> [Line]
layoutLines :: SmallArray Run -> (Float, Float) -> Float -> [Token] -> [Line]
layoutLines SmallArray Run
runs (Float
emptyH, Float
emptyAscent) Float
width = Float
-> [(Float, Token)]
-> Float
-> [Token]
-> Bool
-> [Token]
-> [Line]
go Float
0 [] Float
0 [] Bool
True
  where
    -- @placed@ holds the line's tokens in reverse, @pending@ the spaces since
    -- its last word; @fresh@ whether the line starts after a wrap.
    go :: Float
-> [(Float, Token)]
-> Float
-> [Token]
-> Bool
-> [Token]
-> [Line]
go Float
top [(Float, Token)]
placed Float
x [Token]
pending Bool
fresh [Token]
toks = case [Token]
toks of
      [] -> [Float -> [(Float, Token)] -> Float -> Line
finish Float
top [(Float, Token)]
placed Float
x]
      Token
tok : [Token]
rest -> case Token -> TokenKind
tokenKind Token
tok of
        TokenKind
Break -> let line :: Line
line = Float -> [(Float, Token)] -> Float -> Line
finish Float
top [(Float, Token)]
placed Float
x in Line
line Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
: Float
-> [(Float, Token)]
-> Float
-> [Token]
-> Bool
-> [Token]
-> [Line]
go (Float
top Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineHeight Line
line) [] Float
0 [] Bool
False [Token]
rest
        TokenKind
Space -> Float
-> [(Float, Token)]
-> Float
-> [Token]
-> Bool
-> [Token]
-> [Line]
go Float
top [(Float, Token)]
placed Float
x (Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token]
pending) Bool
fresh [Token]
rest
        TokenKind
Word ->
          let ([Token]
word, [Token]
rest') = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\Token
t -> Token -> TokenKind
tokenKind Token
t TokenKind -> TokenKind -> Bool
forall a. Eq a => a -> a -> Bool
== TokenKind
Word) [Token]
toks
              wordW :: Float
wordW = [Float] -> Float
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Token -> Float) -> [Token] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Float
tokenWidth [Token]
word)
              spaceW :: Float
spaceW = if [(Float, Token)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Float, Token)]
placed Bool -> Bool -> Bool
&& Bool
fresh then Float
0 else [Float] -> Float
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Token -> Float) -> [Token] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map Token -> Float
tokenWidth [Token]
pending)
           in if Bool -> Bool
not ([(Float, Token)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Float, Token)]
placed) Bool -> Bool -> Bool
&& Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
spaceW Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
wordW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
width
                then
                  let line :: Line
line = Float -> [(Float, Token)] -> Float -> Line
finish Float
top [(Float, Token)]
placed Float
x
                   in Line
line Line -> [Line] -> [Line]
forall a. a -> [a] -> [a]
: Float
-> [(Float, Token)]
-> Float
-> [Token]
-> Bool
-> [Token]
-> [Line]
go (Float
top Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Line -> Float
lineHeight Line
line) [] Float
0 [] Bool
True [Token]
toks
                else
                  let ([(Float, Token)]
placed', Float
x') = (([(Float, Token)], Float) -> Token -> ([(Float, Token)], Float))
-> ([(Float, Token)], Float)
-> [Token]
-> ([(Float, Token)], Float)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Float, Token)], Float) -> Token -> ([(Float, Token)], Float)
place ([(Float, Token)]
placed, Float
x) (if [(Float, Token)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Float, Token)]
placed Bool -> Bool -> Bool
&& Bool
fresh then [] else [Token] -> [Token]
forall a. [a] -> [a]
reverse [Token]
pending)
                      ([(Float, Token)]
placed'', Float
x'') = (([(Float, Token)], Float) -> Token -> ([(Float, Token)], Float))
-> ([(Float, Token)], Float)
-> [Token]
-> ([(Float, Token)], Float)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Float, Token)], Float) -> Token -> ([(Float, Token)], Float)
place ([(Float, Token)]
placed', Float
x') [Token]
word
                   in Float
-> [(Float, Token)]
-> Float
-> [Token]
-> Bool
-> [Token]
-> [Line]
go Float
top [(Float, Token)]
placed'' Float
x'' [] Bool
False [Token]
rest'
    place :: ([(Float, Token)], Float) -> Token -> ([(Float, Token)], Float)
place ([(Float, Token)]
acc, Float
x) Token
tok = ((Float
x, Token
tok) (Float, Token) -> [(Float, Token)] -> [(Float, Token)]
forall a. a -> [a] -> [a]
: [(Float, Token)]
acc, Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Token -> Float
tokenWidth Token
tok)
    finish :: Float -> [(Float, Token)] -> Float -> Line
finish Float
top [(Float, Token)]
placed Float
x =
      let toks :: [(Float, Token)]
toks = [(Float, Token)] -> [(Float, Token)]
forall a. [a] -> [a]
reverse [(Float, Token)]
placed
          metrics :: [Run]
metrics = [SmallArray Run -> Int -> Run
forall a. SmallArray a -> Int -> a
indexSmallArray SmallArray Run
runs (Token -> Int
tokenRun Token
tok) | (Float
_, Token
tok) <- [(Float, Token)]
toks]
          (Float
h, Float
ascent) = case [Run]
metrics of
            [] -> (Float
emptyH, Float
emptyAscent)
            [Run]
_ ->
              let ascent' :: Float
ascent' = [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Run -> Float) -> [Run] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map Run -> Float
runAscent [Run]
metrics)
                  descent :: Float
descent = [Float] -> Float
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Run -> Float
runLineHeight Run
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Run -> Float
runAscent Run
r | Run
r <- [Run]
metrics]
               in (Float
ascent' Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
descent, Float
ascent')
       in Float -> Float -> Float -> Float -> [(Float, Token)] -> Line
Line Float
top Float
h Float
ascent Float
x [(Float, Token)]
toks