{-# LANGUAGE BangPatterns #-}

-- | The multi-line text area widget and its state: the document buffer,
-- caret and selection, viewport, and commands run against it.
module NanoUI.Widgets.TextArea
  ( -- * Pure state
    TextAreaState (..)
  , initTextAreaState
  , setTextAreaViewport
  , setTextAreaSelection
    -- * Widget
  , textArea
  , textArea'
  , textAreaWith
  , textAreaWith'
  , textAreaLayout
  , loadTextAreaState
  , loadTextAreaStateWithBuffer
  , saveTextAreaState
  , textAreaEditor
  , runTextAreaCommand
  , applyTextAreaCommand
  ) where

import Control.Monad (foldM, when)
import Data.Dynamic (fromDynamic, toDyn)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.IntMap.Strict as IM
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , damageWidget
  , getStore
  , intKey
  , markDirty
  , registerFocusable
  , setStore
  , setTextInputDrag
  , modifyStore
  )
import NanoUI.Font (fmLineHeight)
import NanoUI.Id (WidgetId)
import NanoUI.Input
  ( Input (..)
  , inputChars
  , inputKeys
  , inputKeysNull
  )
import NanoUI.Layout.Arena (NodeType (..))
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO)
import NanoUI.Store
  ( WidgetStore (..)
  , slotKey
  , Slot (..)
  )
import NanoUI.Style (FontStyle (..), FontVariant (..), FontWeight (..), Layout (..), Sizing (..), defaultLayout)
import NanoUI.Types (DamageBounds (..), clamp)
import NanoUI.Widgets.Behavior (keyboardFocused)
import NanoUI.Widgets.Node (Response, addWidget, setChanged)
import qualified NanoUI.Widgets.TextBuffer as TB
import NanoUI.Widgets.TextEditor
  ( Editor (..)
  , EditHistory
  , TextCommand (..)
  , inputTextCommands
  , editorModeCode
  , emptyHistory
  , multiLineMode
  , runCommand
  , runCommandIO
  , sealHistory
  )

data TextAreaState = TextAreaState
  { TextAreaState -> TextBuffer
buffer :: !TB.TextBuffer
  , TextAreaState -> Cursor
selectionAnchor :: !TB.Cursor
  , TextAreaState -> (Double, Double)
scrollOffset :: !(Double, Double)
  , TextAreaState -> (Double, Double)
viewportSize :: !(Double, Double)
  , TextAreaState -> Double
lineHeight :: !Double
  , TextAreaState -> EditHistory
history :: !EditHistory
  }
  deriving (Int -> TextAreaState -> ShowS
[TextAreaState] -> ShowS
TextAreaState -> String
(Int -> TextAreaState -> ShowS)
-> (TextAreaState -> String)
-> ([TextAreaState] -> ShowS)
-> Show TextAreaState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextAreaState -> ShowS
showsPrec :: Int -> TextAreaState -> ShowS
$cshow :: TextAreaState -> String
show :: TextAreaState -> String
$cshowList :: [TextAreaState] -> ShowS
showList :: [TextAreaState] -> ShowS
Show)

initTextAreaState :: T.Text -> TextAreaState
initTextAreaState :: Text -> TextAreaState
initTextAreaState Text
initial =
  TextAreaState
    { buffer :: TextBuffer
buffer = Text -> TextBuffer
TB.fromText Text
initial
    , selectionAnchor :: Cursor
selectionAnchor = Int -> Int -> Cursor
TB.Cursor Int
0 Int
0
    , scrollOffset :: (Double, Double)
scrollOffset = (Double
0.0, Double
0.0)
    , viewportSize :: (Double, Double)
viewportSize = (Double
0.0, Double
0.0)
    , lineHeight :: Double
lineHeight = Double
16.0
    , history :: EditHistory
history = EditHistory
emptyHistory
    }

setTextAreaViewport :: (Double, Double) -> Double -> TextAreaState -> TextAreaState
setTextAreaViewport :: (Double, Double) -> Double -> TextAreaState -> TextAreaState
setTextAreaViewport (Double, Double)
vp Double
lh TextAreaState
state =
  TextAreaState
state {viewportSize = vp, lineHeight = lh}

cursorOf :: TextAreaState -> TB.Cursor
cursorOf :: TextAreaState -> Cursor
cursorOf TextAreaState
state = TextBuffer -> Cursor
TB.getCursor (TextAreaState -> TextBuffer
buffer TextAreaState
state)

setTextAreaSelection :: TB.Cursor -> TB.Cursor -> TextAreaState -> TextAreaState
setTextAreaSelection :: Cursor -> Cursor -> TextAreaState -> TextAreaState
setTextAreaSelection Cursor
anchor Cursor
cursor TextAreaState
state =
  let buf :: TextBuffer
buf =
        let b :: TextBuffer
b = Cursor -> TextBuffer -> TextBuffer
TB.withCursor Cursor
cursor (TextAreaState -> TextBuffer
buffer TextAreaState
state)
         in TextBuffer
b {TB.preferredCol = TB.cursorCol cursor}
   in TextAreaState -> TextAreaState
ensureCaretVisible TextAreaState
state {buffer = buf, selectionAnchor = anchor}

textAreaEditor :: TextAreaState -> Editor
textAreaEditor :: TextAreaState -> Editor
textAreaEditor TextAreaState
state = TextBuffer -> Cursor -> EditHistory -> Editor
Editor (TextAreaState -> TextBuffer
buffer TextAreaState
state) (TextAreaState -> Cursor
selectionAnchor TextAreaState
state) (TextAreaState -> EditHistory
history TextAreaState
state)

withEditor :: TextAreaState -> Editor -> TextAreaState
withEditor :: TextAreaState -> Editor -> TextAreaState
withEditor TextAreaState
state Editor
ed =
  TextAreaState -> TextAreaState
ensureCaretVisible TextAreaState
state {buffer = editorBuffer ed, selectionAnchor = editorAnchor ed, history = editorHistory ed}

-- | Run a command that needs no clipboard, keeping the caret in view.
runTextAreaCommand :: TextCommand -> TextAreaState -> TextAreaState
runTextAreaCommand :: TextCommand -> TextAreaState -> TextAreaState
runTextAreaCommand TextCommand
cmd TextAreaState
state = TextAreaState -> Editor -> TextAreaState
withEditor TextAreaState
state (EditorMode -> TextCommand -> Editor -> Editor
runCommand EditorMode
multiLineMode TextCommand
cmd (TextAreaState -> Editor
textAreaEditor TextAreaState
state))

ensureCaretVisible :: TextAreaState -> TextAreaState
ensureCaretVisible :: TextAreaState -> TextAreaState
ensureCaretVisible TextAreaState
state =
  let TB.Cursor Int
r Int
_ = TextBuffer -> Cursor
TB.getCursor (TextAreaState -> TextBuffer
buffer TextAreaState
state)
      lh :: Double
lh = TextAreaState -> Double
lineHeight TextAreaState
state
      vh :: Double
vh = (Double, Double) -> Double
forall a b. (a, b) -> b
snd (TextAreaState -> (Double, Double)
viewportSize TextAreaState
state)
      (Double
sx, Double
sy) = TextAreaState -> (Double, Double)
scrollOffset TextAreaState
state
      caretY :: Double
caretY = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lh
      caretH :: Double
caretH = Double
lh
      contentH :: Double
contentH = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TextBuffer -> Int
TB.getLineCount (TextAreaState -> TextBuffer
buffer TextAreaState
state)) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lh
      maxSy :: Double
maxSy = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
contentH Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
vh)
      sy' :: Double
sy'
        | Double
vh Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = Double
0
        | Double
caretY Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
sy = Double
caretY
        | Double
caretY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
caretH Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
sy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
vh = Double
caretY Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
caretH Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
vh
        | Bool
otherwise = Double
sy
  in TextAreaState
state {scrollOffset = (sx, clamp 0 maxSy sy')}

--------------------------------------------------------------------------------
-- Widget
--------------------------------------------------------------------------------

textAreaLayout :: Layout
textAreaLayout :: Layout
textAreaLayout =
  Layout
defaultLayout
    { layoutWidth = Grow 1
    , layoutMinW = 200
    , layoutHeight = Fixed 140
    }

-- | Multi-line text editor. Pass the current text; the result is the text
-- after this frame's edits. Pair it with a 'label' when a caption is wanted.
{-# INLINE textArea #-}
textArea :: Ui :> es => Text -> Eff es Text
textArea :: forall (es :: [Effect]). (Ui :> es) => Text -> Eff es Text
textArea Text
value = (Response, Text) -> Text
forall a b. (a, b) -> b
snd ((Response, Text) -> Text)
-> Eff es (Response, Text) -> Eff es Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout) -> Text -> Eff es (Response, Text)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Text -> Eff es (Response, Text)
textAreaWith' Layout -> Layout
forall a. a -> a
id Text
value

{-# INLINE textArea' #-}
textArea' :: Ui :> es => Text -> Eff es (Response, Text)
textArea' :: forall (es :: [Effect]).
(Ui :> es) =>
Text -> Eff es (Response, Text)
textArea' = (Layout -> Layout) -> Text -> Eff es (Response, Text)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Text -> Eff es (Response, Text)
textAreaWith' Layout -> Layout
forall a. a -> a
id

-- | 'textArea' with a modifier applied to 'textAreaLayout', for example
-- 'grow' to fill the parent.
{-# INLINE textAreaWith #-}
textAreaWith :: Ui :> es => (Layout -> Layout) -> Text -> Eff es Text
textAreaWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Text -> Eff es Text
textAreaWith Layout -> Layout
f Text
value = (Response, Text) -> Text
forall a b. (a, b) -> b
snd ((Response, Text) -> Text)
-> Eff es (Response, Text) -> Eff es Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout) -> Text -> Eff es (Response, Text)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Text -> Eff es (Response, Text)
textAreaWith' Layout -> Layout
f Text
value

textAreaWith' :: Ui :> es => (Layout -> Layout) -> Text -> Eff es (Response, Text)
textAreaWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Text -> Eff es (Response, Text)
textAreaWith' Layout -> Layout
f Text
value = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  uiIO $ registerFocusable ctx wid
  inp <- askInput
  store0 <- uiIO (getStore ctx)
  let layout = Layout -> Layout
f Layout
textAreaLayout
      key = WidgetId -> Int
intKey WidgetId
wid
      seenKey = Slot -> Int -> Int
slotKey Slot
SlotSeen Int
key
      contentCacheKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaContentFont Int
key
      changedSlotKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaChanged Int
key
      texts0 = WidgetStore -> IntMap Text
storeText WidgetStore
store0
      replaced = Int -> IntMap Text -> Maybe Text
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
key IntMap Text
texts0 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
value
  -- Adopt the caller's text the way 'adoptStoreText' does. A replaced document
  -- orphans any cached buffer or content size for the key. Seed the scroll
  -- slot too: the wheel and drag paths write offsets through
  -- setScrollOffset2D, which only updates the text area's slot once it exists.
  -- Its undo history, recorded against the old text, goes with them.
  when (IM.lookup seenKey texts0 /= Just value) $
    uiIO $ setStore ctx
      store0
        { storeText = IM.insert seenKey value (IM.insert key value texts0)
        , storePoint = IM.insertWith (\(Float, Float)
_ (Float, Float)
old -> (Float, Float)
old) (slotKey SlotTextAreaScroll key) (0, 0) (storePoint store0)
        , storeFloat = if replaced then IM.delete contentCacheKey (storeFloat store0) else storeFloat store0
        , storeDyn =
            if replaced
              then IM.delete (slotKey SlotTextHistory key) (IM.delete (slotKey SlotTextAreaBuffer key) (storeDyn store0))
              else storeDyn store0
        , storeInt = IM.insert (slotKey SlotTextMode key) (editorModeCode multiLineMode) (storeInt store0)
        }
  store <- uiIO (getStore ctx)
  let current = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
value Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
      -- Set by commands run outside the frame ('applyTextAreaCommand') whose
      -- edits carry no keys or chars; folded into 'changed' so the caller
      -- gets its respChanged pulse, then cleared in the state write below.
      menuPulse = Int -> IntMap Int -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
changedSlotKey (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
  isFocus <- keyboardFocused wid
  (newText, stateChanged) <-
    if isFocus
      then do
        editFm <-
          if layoutFontSize layout <= 0
            then pure (ctxFontMetrics ctx)
            else fst <$> uiIO (ctxResolveFont ctx (layoutFontSize layout) WeightNormal FontStyleNormal FontRegular)
        let oldState = WidgetStore -> Int -> Text -> TextAreaState
loadTextAreaState WidgetStore
store Int
key Text
value
            s1 = (Double, Double) -> Double -> TextAreaState -> TextAreaState
setTextAreaViewport (TextAreaState -> (Double, Double)
viewportSize TextAreaState
oldState) (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (FontMetrics -> Float
fmLineHeight FontMetrics
editFm)) TextAreaState
oldState
            hadInput = Bool -> Bool
not (Text -> Bool
T.null (Input -> Text
inputChars Input
inp)) Bool -> Bool -> Bool
|| Bool -> Bool
not (SmallArray Key -> Bool
inputKeysNull (Input -> SmallArray Key
inputKeys Input
inp))
        newState <- uiIO $ do
          when hadInput $ setTextInputDrag ctx Nothing
          case inputTextCommands multiLineMode inp of
            [] -> TextAreaState -> IO TextAreaState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TextAreaState
s1
            [TextCommand]
cmds -> TextAreaState -> Editor -> TextAreaState
withEditor TextAreaState
s1 (Editor -> TextAreaState) -> IO Editor -> IO TextAreaState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Editor -> TextCommand -> IO Editor)
-> Editor -> [TextCommand] -> IO Editor
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((TextCommand -> Editor -> IO Editor)
-> Editor -> TextCommand -> IO Editor
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Context -> EditorMode -> TextCommand -> Editor -> IO Editor
runCommandIO Context
ctx EditorMode
multiLineMode)) (TextAreaState -> Editor
textAreaEditor TextAreaState
s1) [TextCommand]
cmds
        let newText
              -- Commands only come from keys or chars, so idle focused frames
              -- skip the O(document) 'TB.toText' and stop at the cheap
              -- cursor/scroll checks.
              | Bool
hadInput Bool -> Bool -> Bool
|| Bool
changed = TextBuffer -> Text
TB.toText (TextAreaState -> TextBuffer
buffer TextAreaState
newState)
              | Bool
otherwise = Text
current
            changed =
              TextAreaState -> Cursor
cursorOf TextAreaState
newState Cursor -> Cursor -> Bool
forall a. Eq a => a -> a -> Bool
/= TextAreaState -> Cursor
cursorOf TextAreaState
oldState
                Bool -> Bool -> Bool
|| TextAreaState -> Cursor
selectionAnchor TextAreaState
newState Cursor -> Cursor -> Bool
forall a. Eq a => a -> a -> Bool
/= TextAreaState -> Cursor
selectionAnchor TextAreaState
oldState
                Bool -> Bool -> Bool
|| TextAreaState -> (Double, Double)
scrollOffset TextAreaState
newState (Double, Double) -> (Double, Double) -> Bool
forall a. Eq a => a -> a -> Bool
/= TextAreaState -> (Double, Double)
scrollOffset TextAreaState
oldState
                Bool -> Bool -> Bool
|| Bool
menuPulse
                Bool -> Bool -> Bool
|| (Bool
hadInput Bool -> Bool -> Bool
&& Text
newText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
current)
        -- Saving writes the new text and its buffer together; drop only the
        -- content size measured for the old text, and the menu pulse. The
        -- store damage is keyed on slots, not the widget, so damage the widget
        -- itself: a selection-only change (Ctrl+A) would otherwise repaint
        -- nothing until the next frame.
        when changed $
          uiIO $ do
            damageWidget ctx wid DamageSelf
            modifyStore ctx $ \WidgetStore
st0 ->
              let st :: WidgetStore
st = Int -> Text -> TextAreaState -> WidgetStore -> WidgetStore
saveTextAreaState Int
key Text
newText TextAreaState
newState WidgetStore
st0
               in WidgetStore
st
                    { storeText = IM.insert seenKey newText (storeText st)
                    , storeInt = IM.delete changedSlotKey (storeInt st)
                    , storeFloat = IM.delete contentCacheKey (storeFloat st)
                    }
        pure (newText, changed)
      else do
        -- A command run on the unfocused area ('applyTextAreaCommand') still
        -- pulses this frame's respChanged, once.
        when menuPulse $
          uiIO $ modifyStore ctx $ \WidgetStore
st -> WidgetStore
st {storeInt = IM.delete changedSlotKey (storeInt st)}
        pure (current, menuPulse)
  resp <- addWidget wid NodeTextArea "" 0 layout
  pure (setChanged stateChanged resp, newText)

loadTextAreaState :: WidgetStore -> Int -> Text -> TextAreaState
loadTextAreaState :: WidgetStore -> Int -> Text -> TextAreaState
loadTextAreaState WidgetStore
store Int
key Text
initial =
  let text :: Text
text = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
initial Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
      -- The buffer cache is written together with storeText by
      -- saveTextAreaState, so a present entry is always the buffer for the
      -- stored text; no (O(document)) re-comparison is needed.
      Maybe TextBuffer
cachedBuffer :: Maybe TB.TextBuffer =
        Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
SlotTextAreaBuffer Int
key) (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
store) Maybe Dynamic -> (Dynamic -> Maybe TextBuffer) -> Maybe TextBuffer
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 TextBuffer
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
      buf0 :: TextBuffer
buf0 = case Maybe TextBuffer
cachedBuffer of
        Just TextBuffer
cached -> TextBuffer
cached
        Maybe TextBuffer
Nothing -> Text -> TextBuffer
TB.fromText Text
text
   in WidgetStore -> Int -> TextBuffer -> TextAreaState
loadTextAreaStateWithBuffer WidgetStore
store Int
key TextBuffer
buf0

-- | 'loadTextAreaState' with the buffer already resolved (the paint path
-- ensures the buffer cache and hands it straight through, avoiding a second
-- store lookup).
loadTextAreaStateWithBuffer :: WidgetStore -> Int -> TB.TextBuffer -> TextAreaState
loadTextAreaStateWithBuffer :: WidgetStore -> Int -> TextBuffer -> TextAreaState
loadTextAreaStateWithBuffer WidgetStore
store Int
key TextBuffer
buf0 =
  let row :: Int
row = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotTextAreaRow Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      col :: Int
col = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotTextAreaCol Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      anchorRow :: Int
anchorRow = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
row (Slot -> Int -> Int
slotKey Slot
SlotTextAreaAnchorRow Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      anchorCol :: Int
anchorCol = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
col (Slot -> Int -> Int
slotKey Slot
SlotTextAreaAnchorCol Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      pref :: Int
pref = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
col (Slot -> Int -> Int
slotKey Slot
SlotTextAreaPrefCol Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      scroll :: (Double, Double)
scroll =
        let (Float
sx, Float
sy) =
              (Float, Float) -> Int -> IntMap (Float, Float) -> (Float, Float)
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (Float
0, Float
0) (Slot -> Int -> Int
slotKey Slot
SlotTextAreaScroll Int
key) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
         in (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
sx, Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
sy)
      viewport :: (Double, Double)
viewport =
        let (Float
vw, Float
vh) =
              (Float, Float) -> Int -> IntMap (Float, Float) -> (Float, Float)
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (Float
200, Float
96) (Slot -> Int -> Int
slotKey Slot
SlotTextAreaViewport Int
key) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
         in (Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
vw, Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
vh)
      buf :: TextBuffer
buf =
        let b :: TextBuffer
b = Cursor -> TextBuffer -> TextBuffer
TB.withCursor (Int -> Int -> Cursor
TB.Cursor Int
row Int
col) TextBuffer
buf0
         in TextBuffer
b {TB.preferredCol = pref}
      anchor :: Cursor
anchor = TextBuffer -> Cursor
TB.getCursor (Cursor -> TextBuffer -> TextBuffer
TB.withCursor (Int -> Int -> Cursor
TB.Cursor Int
anchorRow Int
anchorCol) TextBuffer
buf0)
      -- Replacing the document drops its history, so the recorded text is
      -- always the current one here.
      hist :: EditHistory
hist = case Int -> IntMap Dynamic -> Maybe Dynamic
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
SlotTextHistory Int
key) (WidgetStore -> IntMap Dynamic
storeDyn WidgetStore
store) Maybe Dynamic
-> (Dynamic -> Maybe (Text, EditHistory))
-> Maybe (Text, EditHistory)
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 (Text, EditHistory)
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic of
        Just (Text
_ :: Text, EditHistory
h) -> EditHistory
h
        Maybe (Text, EditHistory)
Nothing -> EditHistory
emptyHistory
   in TextAreaState
        { buffer :: TextBuffer
buffer = TextBuffer
buf
        , selectionAnchor :: Cursor
selectionAnchor = Cursor
anchor
        , scrollOffset :: (Double, Double)
scrollOffset = (Double, Double)
scroll
        , viewportSize :: (Double, Double)
viewportSize = (Double, Double)
viewport
        , lineHeight :: Double
lineHeight = Double
16
        , history :: EditHistory
history = EditHistory
hist
        }

-- | Store the editor state with its text. Callers pass the text because they
-- usually have it already, and 'TB.toText' joins the whole document.
saveTextAreaState :: Int -> Text -> TextAreaState -> WidgetStore -> WidgetStore
saveTextAreaState :: Int -> Text -> TextAreaState -> WidgetStore -> WidgetStore
saveTextAreaState Int
key Text
text TextAreaState
state WidgetStore
store =
  let TB.Cursor Int
row Int
col = TextBuffer -> Cursor
TB.getCursor (TextAreaState -> TextBuffer
buffer TextAreaState
state)
      TB.Cursor Int
anchorRow Int
anchorCol = TextAreaState -> Cursor
selectionAnchor TextAreaState
state
   in WidgetStore
store
        { storeText = IM.insert key text (storeText store)
        , storeDyn =
            IM.insert (slotKey SlotTextAreaBuffer key) (toDyn (buffer state)) $
              IM.insert (slotKey SlotTextHistory key) (toDyn (text, history state)) (storeDyn store)
        , storeInt =
            IM.insert (slotKey SlotTextAreaRow key) row $
              IM.insert (slotKey SlotTextAreaCol key) col $
                IM.insert (slotKey SlotTextAreaPrefCol key) (TB.preferredCol (buffer state)) $
                  IM.insert (slotKey SlotTextAreaAnchorRow key) anchorRow $
                    IM.insert (slotKey SlotTextAreaAnchorCol key) anchorCol (storeInt store)
        , storePoint =
            IM.insert (slotKey SlotTextAreaScroll key) (realToFrac sx, realToFrac sy) $
              IM.insert (slotKey SlotTextAreaViewport key) (realToFrac vw, realToFrac vh) (storePoint store)
        }
  where
    (Double
sx, Double
sy) = TextAreaState -> (Double, Double)
scrollOffset TextAreaState
state
    (Double
vw, Double
vh) = TextAreaState -> (Double, Double)
viewportSize TextAreaState
state

-- | Run a command on a text area outside its frame (a context menu row, an
-- app's Edit menu). A change to the text pulses 'respChanged' on the area's
-- next frame.
applyTextAreaCommand :: Context -> WidgetId -> TextCommand -> IO ()
applyTextAreaCommand :: Context -> WidgetId -> TextCommand -> IO ()
applyTextAreaCommand Context
ctx WidgetId
wid TextCommand
cmd = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      text = Text -> Int -> IntMap Text -> Text
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Text
"" Int
key (WidgetStore -> IntMap Text
storeText WidgetStore
store)
      s0 = WidgetStore -> Int -> Text -> TextAreaState
loadTextAreaState WidgetStore
store Int
key Text
text
  s1 <- withEditor s0 <$> runCommandIO ctx multiLineMode cmd (textAreaEditor s0 {history = sealHistory (history s0)})
  let newText = TextBuffer -> Text
TB.toText (TextAreaState -> TextBuffer
buffer TextAreaState
s1)
      saved = Int -> Text -> TextAreaState -> WidgetStore -> WidgetStore
saveTextAreaState Int
key Text
newText TextAreaState
s1 WidgetStore
store
  -- A changed text also drops the content size measured for the old one.
  setStore ctx $
    if newText == text
      then saved
      else
        saved
          { storeInt = IM.insert (slotKey SlotTextAreaChanged key) 1 (storeInt saved)
          , storeFloat = IM.delete (slotKey SlotTextAreaContentFont key) (storeFloat saved)
          }
  -- Store damage is keyed on slots, not the widget: damage the widget so a
  -- selection-only command (Select All) repaints this frame.
  damageWidget ctx wid DamageSelf
  markDirty ctx