{-# LANGUAGE BangPatterns #-}

-- | Store-backed text-area content shared by painting, scrolling and hit
-- testing: the node font, the cached document buffer and the cached content
-- extent. Free of the editor widget modules so scroll code stays light.
module NanoUI.Frame.TextArea.Content
  ( resolveTextAreaFont
  , ensureTextAreaBuffer
  , textAreaContentMetrics
  , textAreaContentGeom
  , isMouseOnTextAreaScrollBarAt
  ) where

import Data.Dynamic (fromDynamic, toDyn)
import Data.IORef (readIORef)
import qualified Data.IntMap.Strict as IM
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import NanoUI.Context (Context (..), WidgetStore (..), getStore, intKey, setStore, slotKey)
import NanoUI.Font (FontMetrics (..), lineWidthIO)
import NanoUI.Frame.TextArea.Geometry (isMouseOnTextAreaScrollBar)
import NanoUI.Layout.Arena (NodeIdx, getNodeFontSize, getRect, getWidgetId)
import NanoUI.Store
  ( Slot (..)
  )
import NanoUI.Style (FontStyle (..), FontVariant (..), FontWeight (..))
import NanoUI.Types (Rect (..), V2, onGrid)
import qualified NanoUI.Widgets.TextBuffer as TB

-- | Font the text-area content is laid out and painted in. Honors the node's
-- @layoutFontSize@ (set via 'fontSize' on the editor layout) so a single text
-- area can zoom without changing the rest of the UI. A size of 0 means the
-- base UI font.
resolveTextAreaFont :: Context -> NodeIdx -> IO FontMetrics
resolveTextAreaFont :: Context -> Int -> IO FontMetrics
resolveTextAreaFont Context
ctx Int
idx = do
  size <- NodeArena -> Int -> IO Float
getNodeFontSize (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  if size <= 0
    then pure (ctxFontMetrics ctx)
    else fst <$> ctxResolveFont ctx size WeightNormal FontStyleNormal FontRegular

-- | Return the text area's 'TB.TextBuffer', building it from the flat text only
-- when the cache is cold. Rebuilding splits the whole document into lines, so
-- caching it keeps loads and paint O(1) here. The cache is written together
-- with the flat text by 'saveTextAreaState', so a present entry is always the
-- buffer for the stored text.
ensureTextAreaBuffer :: Context -> Int -> Text -> IO TB.TextBuffer
ensureTextAreaBuffer :: Context -> Int -> Text -> IO TextBuffer
ensureTextAreaBuffer Context
ctx Int
key Text
text = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  case IM.lookup (slotKey SlotTextAreaBuffer key) (storeDyn store) >>= fromDynamic of
    Just TextBuffer
buf -> TextBuffer -> IO TextBuffer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextBuffer
buf
    Maybe TextBuffer
Nothing -> do
      let buf :: TextBuffer
buf = Text -> TextBuffer
TB.fromText Text
text
      Context -> WidgetStore -> IO ()
setStore Context
ctx WidgetStore
store {storeDyn = IM.insert (slotKey SlotTextAreaBuffer key) (toDyn buf) (storeDyn store)}
      TextBuffer -> IO TextBuffer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextBuffer
buf

-- | Content extent of a text area, @(contentWidth, contentHeight)@. Measuring
-- the width scans every character of the document, so the result is cached per
-- widget and only refreshed when the text changes (the editor clears
-- 'SlotTextAreaContentFont') or the node font changes.
textAreaContentMetrics :: Context -> NodeIdx -> IO (Float, Float)
textAreaContentMetrics :: Context -> Int -> IO (Float, Float)
textAreaContentMetrics Context
ctx Int
idx = do
  wid <- NodeArena -> Int -> IO WidgetId
getWidgetId (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
  size <- getNodeFontSize (ctxNodeArena ctx) idx
  store <- getStore ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      cacheKeyF = Slot -> Int -> Int
slotKey Slot
SlotTextAreaContentFont Int
key
      cacheKeyW = Slot -> Int -> Int
slotKey Slot
SlotTextAreaContentW Int
key
      cacheKeyH = Slot -> Int -> Int
slotKey Slot
SlotTextAreaContentH Int
key
      widthsKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaWidths Int
key
      cachedFont = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (-Float
1) Int
cacheKeyF (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
      cachedW = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (-Float
1) Int
cacheKeyW (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
  if cachedFont == size && cachedW >= 0
    then pure (cachedW, IM.findWithDefault 0 cacheKeyH (storeFloat store))
    else do
      fm <- resolveTextAreaFont ctx idx
      gen <- readIORef (ctxMetricGen ctx)
      buf <- ensureTextAreaBuffer ctx key (IM.findWithDefault "" key (storeText store))
      let lns = TextBuffer -> Seq Text
TB.bufferLines TextBuffer
buf
          lineH = Float -> Float -> Float
onGrid (FontMetrics -> Float
fmSnapScale FontMetrics
fm) (FontMetrics -> Float
fmLineHeight FontMetrics
fm)
          contentH = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Seq Text -> Int
forall a. Seq a -> Int
Seq.length Seq Text
lns)) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
lineH
          (seenHead, seenTail) = TB.changedLines buf
          previous = case Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
widthsKey (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
store) Maybe Dynamic -> (Dynamic -> Maybe LineWidths) -> Maybe LineWidths
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe LineWidths
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic of
            Just lw :: LineWidths
lw@(LineWidths Float
font Int
fontGen Seq Float
_ Int
_ Float
_) | Float
font Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
size Bool -> Bool -> Bool
&& Int
fontGen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
gen -> LineWidths
lw
            Maybe LineWidths
_ -> Float -> Int -> Seq Float -> Int -> Float -> LineWidths
LineWidths Float
size Int
gen Seq Float
forall a. Seq a
Seq.empty (-Int
1) Float
0
          LineWidths _ _ measured widest widestW = previous
          -- Keep the widths of the lines no edit touched since the last
          -- measurement and measure the rest.
          keepHead = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
seenHead (Seq Float -> Int
forall a. Seq a -> Int
Seq.length Seq Float
measured)
          keepTail = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
seenTail (Seq Float -> Int
forall a. Seq a -> Int
Seq.length Seq Float
measured Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
keepHead)
          changed = Int -> Seq Text -> Seq Text
forall a. Int -> Seq a -> Seq a
Seq.take (Seq Text -> Int
forall a. Seq a -> Int
Seq.length Seq Text
lns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
keepHead Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
keepTail) (Int -> Seq Text -> Seq Text
forall a. Int -> Seq a -> Seq a
Seq.drop Int
keepHead Seq Text
lns)
      fresh <- traverse (lineWidthIO fm) changed
      let widths = Int -> Seq Float -> Seq Float
forall a. Int -> Seq a -> Seq a
Seq.take Int
keepHead Seq Float
measured Seq Float -> Seq Float -> Seq Float
forall a. Semigroup a => a -> a -> a
<> Seq Float
fresh Seq Float -> Seq Float -> Seq Float
forall a. Semigroup a => a -> a -> a
<> Int -> Seq Float -> Seq Float
forall a. Int -> Seq a -> Seq a
Seq.drop (Seq Float -> Int
forall a. Seq a -> Int
Seq.length Seq Float
measured Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
keepTail) Seq Float
measured
          shift = Seq Text -> Int
forall a. Seq a -> Int
Seq.length Seq Text
lns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Seq Float -> Int
forall a. Seq a -> Int
Seq.length Seq Float
measured
          freshWidest = ((Int, Float) -> Int -> Float -> (Int, Float))
-> (Int, Float) -> Seq Float -> (Int, Float)
forall b a. (b -> Int -> a -> b) -> b -> Seq a -> b
Seq.foldlWithIndex (\(Int, Float)
best Int
i Float
w -> if Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> (Int, Float) -> Float
forall a b. (a, b) -> b
snd (Int, Float)
best then (Int
keepHead Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, Float
w) else (Int, Float)
best) (-Int
1, Float
0) Seq Float
fresh
          -- The widest line so far still counts when it was kept; only when
          -- an edit touched it do the widths need a full pass.
          -- A changed line at least as wide as the old widest also still wins.
          (widest', contentW)
            | widest >= 0 && widest < keepHead = pick (widest, widestW) freshWidest
            | widest >= 0 && widest >= Seq.length measured - keepTail = pick (widest + shift, widestW) freshWidest
            | widest >= 0 && snd freshWidest >= widestW = freshWidest
            | otherwise = Seq.foldlWithIndex (\(Int, Float)
best Int
i Float
w -> if Float
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> (Int, Float) -> Float
forall a b. (a, b) -> b
snd (Int, Float)
best then (Int
i, Float
w) else (Int, Float)
best) (-1, 0) widths
          pick (a, a)
a (a, a)
b = if (a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
b a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> (a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
a then (a, a)
b else (a, a)
a
      store' <- getStore ctx
      setStore
        ctx
        ( store'
            { storeFloat =
                IM.insert cacheKeyF size $
                  IM.insert cacheKeyH contentH $
                    IM.insert cacheKeyW contentW (storeFloat store')
            , storeDyn =
                IM.insert widthsKey (toDyn (LineWidths size gen widths widest' contentW)) $
                  IM.insert (slotKey SlotTextAreaBuffer key) (toDyn (TB.markLinesSeen buf)) (storeDyn store')
            }
        )
      pure (contentW, contentH)

-- | Measured widths of a text area's lines, the font size and metric
-- generation they were measured at, and the widest line with its width.
data LineWidths = LineWidths !Float !Int !(Seq Float) !Int !Float

-- | Node font, field rect and content extent @(width, height)@ of a text area.
-- Zoom changes the node font, so scroll and hit math resolve it here rather
-- than using the base font, or the scroll range would clamp short.
textAreaContentGeom :: Context -> NodeIdx -> IO (FontMetrics, Rect, Float, Float)
textAreaContentGeom :: Context -> Int -> IO (FontMetrics, Rect, Float, Float)
textAreaContentGeom Context
ctx Int
idx = do
  fm <- Context -> Int -> IO FontMetrics
resolveTextAreaFont Context
ctx Int
idx
  (x, y, w, h) <- getRect (ctxNodeArena ctx) idx
  (contentW, contentH) <- textAreaContentMetrics ctx idx
  pure (fm, Rect x y w h, contentW, contentH)

-- | Whether @mouse@ is over one of the text area's shown scrollbars. Uses the
-- cached content extent: this runs on every hover through the cursor query.
isMouseOnTextAreaScrollBarAt :: Context -> NodeIdx -> V2 -> IO Bool
isMouseOnTextAreaScrollBarAt :: Context -> Int -> V2 -> IO Bool
isMouseOnTextAreaScrollBarAt Context
ctx Int
idx V2
mouse = do
  (fm, field, contentW, contentH) <- Context -> Int -> IO (FontMetrics, Rect, Float, Float)
textAreaContentGeom Context
ctx Int
idx
  wid <- getWidgetId (ctxNodeArena ctx) idx
  store <- getStore ctx
  let (sx, sy) = IM.findWithDefault (0, 0) (slotKey SlotTextAreaScroll (intKey wid)) (storePoint store)
  pure (isMouseOnTextAreaScrollBar fm field contentW contentH sx sy mouse)