-- | The editing core every text field shares: a document, a selection and an
-- undo history, changed only by 'TextCommand's. Keys and menu rows map onto
-- commands, and an app can run the same commands on a field.
module NanoUI.Widgets.TextEditor
  ( -- * Commands
    TextCommand (..)
  , TextMotion (..)
    -- * Editors
  , Editor (..)
  , EditorMode (..)
  , singleLineMode
  , multiLineMode
  , editorModeCode
  , editorModeFromCode
  , editorFromBuffer
  , editorSelection
  , hasSelection
  , runCommand
  , runCommandIO
    -- * Key bindings
  , inputTextCommands
  , keyCommand
    -- * History
  , EditHistory (..)
  , EditGroup (..)
  , StoredEdit (..)
  , EditKind (..)
  , emptyHistory
  , sealHistory
  , canUndo
  , canRedo
  ) where

import Control.Monad (void, when)
import Data.Bits ((.&.), (.|.))
import Data.Char (isPrint, isSpace, toLower)
import Data.Text qualified as T
import Data.Text.Short qualified as TS
import NanoUI.Context (Context (..))
import NanoUI.Input (Input (..), Key (..), Modifiers (..))
import NanoUI.Widgets.TextBuffer (Cursor (..), TextBuffer, TextEdit (..))
import NanoUI.Widgets.TextCommand (TextCommand (..), TextMotion (..))
import NanoUI.Widgets.TextBuffer qualified as TB

-- | How a field lets its document be changed.
data EditorMode = EditorMode
  { EditorMode -> Bool
modeMultiLine :: !Bool
  , EditorMode -> Bool
modeEditable :: !Bool
  -- ^ Off for selectable labels: only motion, selection and copy apply.
  , EditorMode -> Bool
modeCopyable :: !Bool
  -- ^ Off for passwords: nothing reaches the clipboard.
  }
  deriving (EditorMode -> EditorMode -> Bool
(EditorMode -> EditorMode -> Bool)
-> (EditorMode -> EditorMode -> Bool) -> Eq EditorMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EditorMode -> EditorMode -> Bool
== :: EditorMode -> EditorMode -> Bool
$c/= :: EditorMode -> EditorMode -> Bool
/= :: EditorMode -> EditorMode -> Bool
Eq, Int -> EditorMode -> ShowS
[EditorMode] -> ShowS
EditorMode -> String
(Int -> EditorMode -> ShowS)
-> (EditorMode -> String)
-> ([EditorMode] -> ShowS)
-> Show EditorMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EditorMode -> ShowS
showsPrec :: Int -> EditorMode -> ShowS
$cshow :: EditorMode -> String
show :: EditorMode -> String
$cshowList :: [EditorMode] -> ShowS
showList :: [EditorMode] -> ShowS
Show)

singleLineMode :: EditorMode
singleLineMode :: EditorMode
singleLineMode = EditorMode {modeMultiLine :: Bool
modeMultiLine = Bool
False, modeEditable :: Bool
modeEditable = Bool
True, modeCopyable :: Bool
modeCopyable = Bool
True}

multiLineMode :: EditorMode
multiLineMode :: EditorMode
multiLineMode = EditorMode
singleLineMode {modeMultiLine = True}

-- | A mode as a store integer, so a command sent to a widget id between
-- frames knows what kind of field it edits.
editorModeCode :: EditorMode -> Int
editorModeCode :: EditorMode -> Int
editorModeCode EditorMode
m =
  Int
8
    Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (if EditorMode -> Bool
modeMultiLine EditorMode
m then Int
1 else Int
0)
    Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (if EditorMode -> Bool
modeEditable EditorMode
m then Int
0 else Int
2)
    Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (if EditorMode -> Bool
modeCopyable EditorMode
m then Int
0 else Int
4)

editorModeFromCode :: Int -> Maybe EditorMode
editorModeFromCode :: Int -> Maybe EditorMode
editorModeFromCode Int
code
  | Int
code Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Maybe EditorMode
forall a. Maybe a
Nothing
  | Bool
otherwise =
      EditorMode -> Maybe EditorMode
forall a. a -> Maybe a
Just
        EditorMode
          { modeMultiLine :: Bool
modeMultiLine = Int
code Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
          , modeEditable :: Bool
modeEditable = Int
code Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          , modeCopyable :: Bool
modeCopyable = Int
code Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
4 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          }

-- | A document with its selection (the cursor is the buffer's, the anchor
-- the other end) and history.
data Editor = Editor
  { Editor -> TextBuffer
editorBuffer :: !TextBuffer
  , Editor -> Cursor
editorAnchor :: !Cursor
  , Editor -> EditHistory
editorHistory :: !EditHistory
  }
  deriving (Int -> Editor -> ShowS
[Editor] -> ShowS
Editor -> String
(Int -> Editor -> ShowS)
-> (Editor -> String) -> ([Editor] -> ShowS) -> Show Editor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Editor -> ShowS
showsPrec :: Int -> Editor -> ShowS
$cshow :: Editor -> String
show :: Editor -> String
$cshowList :: [Editor] -> ShowS
showList :: [Editor] -> ShowS
Show)

editorFromBuffer :: TextBuffer -> Editor
editorFromBuffer :: TextBuffer -> Editor
editorFromBuffer TextBuffer
buf = TextBuffer -> Cursor -> EditHistory -> Editor
Editor TextBuffer
buf (TextBuffer -> Cursor
TB.getCursor TextBuffer
buf) EditHistory
emptyHistory

-- | @(anchor, cursor)@.
editorSelection :: Editor -> (Cursor, Cursor)
editorSelection :: Editor -> (Cursor, Cursor)
editorSelection Editor
ed = (Editor -> Cursor
editorAnchor Editor
ed, TextBuffer -> Cursor
TB.getCursor (Editor -> TextBuffer
editorBuffer Editor
ed))

hasSelection :: Editor -> Bool
hasSelection :: Editor -> Bool
hasSelection Editor
ed = Editor -> Cursor
editorAnchor Editor
ed Cursor -> Cursor -> Bool
forall a. Eq a => a -> a -> Bool
/= TextBuffer -> Cursor
TB.getCursor (Editor -> TextBuffer
editorBuffer Editor
ed)

--------------------------------------------------------------------------------
-- History
--------------------------------------------------------------------------------

-- | What started a group of edits, which decides what may join it.
data EditKind = EditTyping | EditDeleting | EditOther
  deriving (EditKind -> EditKind -> Bool
(EditKind -> EditKind -> Bool)
-> (EditKind -> EditKind -> Bool) -> Eq EditKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EditKind -> EditKind -> Bool
== :: EditKind -> EditKind -> Bool
$c/= :: EditKind -> EditKind -> Bool
/= :: EditKind -> EditKind -> Bool
Eq, Int -> EditKind -> ShowS
[EditKind] -> ShowS
EditKind -> String
(Int -> EditKind -> ShowS)
-> (EditKind -> String) -> ([EditKind] -> ShowS) -> Show EditKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EditKind -> ShowS
showsPrec :: Int -> EditKind -> ShowS
$cshow :: EditKind -> String
show :: EditKind -> String
$cshowList :: [EditKind] -> ShowS
showList :: [EditKind] -> ShowS
Show)

-- | An edit as history keeps it. Undo steps live for the life of a field and
-- are rarely replayed, so their texts are compact copies: they cost two
-- words less than a 'T.Text', and never keep alive the larger text a slice
-- was cut from.
data StoredEdit = StoredEdit !Cursor !TS.ShortText !TS.ShortText
  deriving (StoredEdit -> StoredEdit -> Bool
(StoredEdit -> StoredEdit -> Bool)
-> (StoredEdit -> StoredEdit -> Bool) -> Eq StoredEdit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoredEdit -> StoredEdit -> Bool
== :: StoredEdit -> StoredEdit -> Bool
$c/= :: StoredEdit -> StoredEdit -> Bool
/= :: StoredEdit -> StoredEdit -> Bool
Eq, Int -> StoredEdit -> ShowS
[StoredEdit] -> ShowS
StoredEdit -> String
(Int -> StoredEdit -> ShowS)
-> (StoredEdit -> String)
-> ([StoredEdit] -> ShowS)
-> Show StoredEdit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoredEdit -> ShowS
showsPrec :: Int -> StoredEdit -> ShowS
$cshow :: StoredEdit -> String
show :: StoredEdit -> String
$cshowList :: [StoredEdit] -> ShowS
showList :: [StoredEdit] -> ShowS
Show)

-- | Edits undone and redone as one step.
data EditGroup = EditGroup
  { EditGroup -> EditKind
groupKind :: !EditKind
  , EditGroup -> [StoredEdit]
groupEdits :: ![StoredEdit]
  -- ^ Newest first.
  , EditGroup -> (Cursor, Cursor)
groupBefore :: !(Cursor, Cursor)
  -- ^ Anchor and cursor before the first edit.
  , EditGroup -> (Cursor, Cursor)
groupAfter :: !(Cursor, Cursor)
  -- ^ Anchor and cursor after the last edit.
  }
  deriving (EditGroup -> EditGroup -> Bool
(EditGroup -> EditGroup -> Bool)
-> (EditGroup -> EditGroup -> Bool) -> Eq EditGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EditGroup -> EditGroup -> Bool
== :: EditGroup -> EditGroup -> Bool
$c/= :: EditGroup -> EditGroup -> Bool
/= :: EditGroup -> EditGroup -> Bool
Eq, Int -> EditGroup -> ShowS
[EditGroup] -> ShowS
EditGroup -> String
(Int -> EditGroup -> ShowS)
-> (EditGroup -> String)
-> ([EditGroup] -> ShowS)
-> Show EditGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EditGroup -> ShowS
showsPrec :: Int -> EditGroup -> ShowS
$cshow :: EditGroup -> String
show :: EditGroup -> String
$cshowList :: [EditGroup] -> ShowS
showList :: [EditGroup] -> ShowS
Show)

data EditHistory = EditHistory
  { EditHistory -> [EditGroup]
historyUndo :: ![EditGroup]
  , EditHistory -> [EditGroup]
historyRedo :: ![EditGroup]
  , EditHistory -> Int
historyDepth :: !Int
  -- ^ Length of 'historyUndo'.
  , EditHistory -> Bool
historyOpen :: !Bool
  -- ^ Whether the next edit may join the newest group. Undo, redo, cursor
  -- moves and commands from outside the field close it.
  }
  deriving (EditHistory -> EditHistory -> Bool
(EditHistory -> EditHistory -> Bool)
-> (EditHistory -> EditHistory -> Bool) -> Eq EditHistory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EditHistory -> EditHistory -> Bool
== :: EditHistory -> EditHistory -> Bool
$c/= :: EditHistory -> EditHistory -> Bool
/= :: EditHistory -> EditHistory -> Bool
Eq, Int -> EditHistory -> ShowS
[EditHistory] -> ShowS
EditHistory -> String
(Int -> EditHistory -> ShowS)
-> (EditHistory -> String)
-> ([EditHistory] -> ShowS)
-> Show EditHistory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EditHistory -> ShowS
showsPrec :: Int -> EditHistory -> ShowS
$cshow :: EditHistory -> String
show :: EditHistory -> String
$cshowList :: [EditHistory] -> ShowS
showList :: [EditHistory] -> ShowS
Show)

emptyHistory :: EditHistory
emptyHistory :: EditHistory
emptyHistory = [EditGroup] -> [EditGroup] -> Int -> Bool -> EditHistory
EditHistory [] [] Int
0 Bool
False

-- | Start the next edit in a group of its own.
sealHistory :: EditHistory -> EditHistory
sealHistory :: EditHistory -> EditHistory
sealHistory EditHistory
h = EditHistory
h {historyOpen = False}

canUndo :: EditHistory -> Bool
canUndo :: EditHistory -> Bool
canUndo = Bool -> Bool
not (Bool -> Bool) -> (EditHistory -> Bool) -> EditHistory -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EditGroup] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([EditGroup] -> Bool)
-> (EditHistory -> [EditGroup]) -> EditHistory -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditHistory -> [EditGroup]
historyUndo

canRedo :: EditHistory -> Bool
canRedo :: EditHistory -> Bool
canRedo = Bool -> Bool
not (Bool -> Bool) -> (EditHistory -> Bool) -> EditHistory -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EditGroup] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([EditGroup] -> Bool)
-> (EditHistory -> [EditGroup]) -> EditHistory -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EditHistory -> [EditGroup]
historyRedo

-- | Undo steps kept per field. Older steps are dropped in batches.
maxHistoryDepth :: Int
maxHistoryDepth :: Int
maxHistoryDepth = Int
500

-- | Record an edit. Typing joins the group before it while the selection is
-- where that group left it, until a new word starts; consecutive deletes
-- join the same way. Anything else starts a group. Recording clears redo.
record :: EditKind -> (Cursor, Cursor) -> TextEdit -> (Cursor, Cursor) -> EditHistory -> EditHistory
record :: EditKind
-> (Cursor, Cursor)
-> TextEdit
-> (Cursor, Cursor)
-> EditHistory
-> EditHistory
record EditKind
kind (Cursor, Cursor)
before TextEdit
edit (Cursor, Cursor)
after (EditHistory [EditGroup]
undos [EditGroup]
_ Int
depth Bool
open) =
  case [EditGroup]
undos of
    EditGroup
g : [EditGroup]
rest
      | EditGroup -> Bool
joins EditGroup
g ->
          [EditGroup] -> [EditGroup] -> Int -> Bool -> EditHistory
EditHistory (EditGroup
g {groupEdits = stored : groupEdits g, groupAfter = after} EditGroup -> [EditGroup] -> [EditGroup]
forall a. a -> [a] -> [a]
: [EditGroup]
rest) [] Int
depth Bool
True
    [EditGroup]
_ ->
      let depth' :: Int
depth' = Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          group :: EditGroup
group = EditKind
-> [StoredEdit]
-> (Cursor, Cursor)
-> (Cursor, Cursor)
-> EditGroup
EditGroup EditKind
kind [StoredEdit
stored] (Cursor, Cursor)
before (Cursor, Cursor)
after
       in if Int
depth' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxHistoryDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
50
            then [EditGroup] -> [EditGroup] -> Int -> Bool -> EditHistory
EditHistory (Int -> [EditGroup] -> [EditGroup]
forall a. Int -> [a] -> [a]
take Int
maxHistoryDepth (EditGroup
group EditGroup -> [EditGroup] -> [EditGroup]
forall a. a -> [a] -> [a]
: [EditGroup]
undos)) [] Int
maxHistoryDepth Bool
True
            else [EditGroup] -> [EditGroup] -> Int -> Bool -> EditHistory
EditHistory (EditGroup
group EditGroup -> [EditGroup] -> [EditGroup]
forall a. a -> [a] -> [a]
: [EditGroup]
undos) [] Int
depth' Bool
True
  where
    stored :: StoredEdit
stored = Cursor -> ShortText -> ShortText -> StoredEdit
StoredEdit (TextEdit -> Cursor
editAt TextEdit
edit) (Text -> ShortText
TS.fromText (TextEdit -> Text
editRemoved TextEdit
edit)) (Text -> ShortText
TS.fromText (TextEdit -> Text
editInserted TextEdit
edit))
    joins :: EditGroup -> Bool
joins EditGroup
g =
      Bool
open
        Bool -> Bool -> Bool
&& EditKind
kind EditKind -> EditKind -> Bool
forall a. Eq a => a -> a -> Bool
/= EditKind
EditOther
        Bool -> Bool -> Bool
&& EditGroup -> EditKind
groupKind EditGroup
g EditKind -> EditKind -> Bool
forall a. Eq a => a -> a -> Bool
== EditKind
kind
        Bool -> Bool -> Bool
&& EditGroup -> (Cursor, Cursor)
groupAfter EditGroup
g (Cursor, Cursor) -> (Cursor, Cursor) -> Bool
forall a. Eq a => a -> a -> Bool
== (Cursor, Cursor)
before
        Bool -> Bool -> Bool
&& (EditKind
kind EditKind -> EditKind -> Bool
forall a. Eq a => a -> a -> Bool
/= EditKind
EditTyping Bool -> Bool -> Bool
|| Bool -> Bool
not (EditGroup -> Bool
startsWord EditGroup
g))
    -- A letter typed after a space starts a new undo step.
    startsWord :: EditGroup -> Bool
startsWord EditGroup
g = case (EditGroup -> [StoredEdit]
groupEdits EditGroup
g, Text -> Maybe (Char, Text)
T.uncons (TextEdit -> Text
editInserted TextEdit
edit)) of
      (StoredEdit Cursor
_ ShortText
_ ShortText
prevInserted : [StoredEdit]
_, Just (Char
c, Text
_)) -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Bool
-> ((ShortText, Char) -> Bool) -> Maybe (ShortText, Char) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
isSpace (Char -> Bool)
-> ((ShortText, Char) -> Char) -> (ShortText, Char) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShortText, Char) -> Char
forall a b. (a, b) -> b
snd) (ShortText -> Maybe (ShortText, Char)
TS.unsnoc ShortText
prevInserted)
      ([StoredEdit], Maybe (Char, Text))
_ -> Bool
False

--------------------------------------------------------------------------------
-- Commands
--------------------------------------------------------------------------------

-- | Run a command that needs no clipboard. 'Cut', 'Copy' and 'Paste' do
-- nothing here; 'runCommandIO' runs them.
runCommand :: EditorMode -> TextCommand -> Editor -> Editor
runCommand :: EditorMode -> TextCommand -> Editor -> Editor
runCommand EditorMode
mode TextCommand
cmd ed :: Editor
ed@(Editor TextBuffer
buf Cursor
anchor EditHistory
hist) =
  case TextCommand
cmd of
    InsertText Text
raw
      | EditorMode -> Bool
modeEditable EditorMode
mode ->
          let txt :: Text
txt = Text -> Text
singleLine Text
raw
              kind :: EditKind
kind
                | Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"\n" = EditKind
EditTyping
                | Bool
otherwise = EditKind
EditOther
           in if Text -> Bool
T.null Text
txt Bool -> Bool -> Bool
&& Bool -> Bool
not (Editor -> Bool
hasSelection Editor
ed) then Editor
ed else EditKind -> Text -> Editor
replaceSelection EditKind
kind Text
txt
    Delete TextMotion
motion
      | EditorMode -> Bool
modeEditable EditorMode
mode ->
          if Editor -> Bool
hasSelection Editor
ed
            then EditKind -> Text -> Editor
replaceSelection EditKind
EditDeleting Text
T.empty
            else
              let target :: Cursor
target = TextMotion -> Cursor
motionTarget TextMotion
motion
               in if Cursor
target Cursor -> Cursor -> Bool
forall a. Eq a => a -> a -> Bool
== Cursor
cursor
                    then Editor
ed
                    else EditKind -> TextEdit -> Editor
edit EditKind
EditDeleting (Text -> Cursor -> Cursor -> TextBuffer -> TextEdit
TB.replaceEdit Text
T.empty Cursor
cursor Cursor
target TextBuffer
buf)
    Move TextMotion
motion Bool
extend ->
      let moved :: TextBuffer
moved = TextMotion -> TextBuffer
moveBuffer TextMotion
motion
       in TextBuffer -> Cursor -> EditHistory -> Editor
Editor TextBuffer
moved (if Bool
extend then Cursor
anchor else TextBuffer -> Cursor
TB.getCursor TextBuffer
moved) (EditHistory -> EditHistory
sealHistory EditHistory
hist)
    TextCommand
SelectAll ->
      let end :: Cursor
end = TextBuffer -> Cursor
TB.documentEnd TextBuffer
buf
       in TextBuffer -> Cursor -> EditHistory -> Editor
Editor (Cursor -> TextBuffer -> TextBuffer
TB.withCursor Cursor
end TextBuffer
buf) (Int -> Int -> Cursor
Cursor Int
0 Int
0) (EditHistory -> EditHistory
sealHistory EditHistory
hist)
    Select Cursor
a Cursor
c ->
      TextBuffer -> Cursor -> EditHistory -> Editor
Editor (Cursor -> TextBuffer -> TextBuffer
TB.withCursor Cursor
c TextBuffer
buf) (TextBuffer -> Cursor -> Cursor
TB.clampCursor TextBuffer
buf Cursor
a) (EditHistory -> EditHistory
sealHistory EditHistory
hist)
    Replace Cursor
a Cursor
b Text
txt
      | EditorMode -> Bool
modeEditable EditorMode
mode -> EditKind -> TextEdit -> Editor
edit EditKind
EditOther (Text -> Cursor -> Cursor -> TextBuffer -> TextEdit
TB.replaceEdit (Text -> Text
singleLine Text
txt) Cursor
a Cursor
b TextBuffer
buf)
    ReplaceAll Text
txt
      | EditorMode -> Bool
modeEditable EditorMode
mode ->
          EditKind -> TextEdit -> Editor
edit EditKind
EditOther (Text -> Cursor -> Cursor -> TextBuffer -> TextEdit
TB.replaceEdit (Text -> Text
singleLine Text
txt) (Int -> Int -> Cursor
Cursor Int
0 Int
0) (TextBuffer -> Cursor
TB.documentEnd TextBuffer
buf) TextBuffer
buf)
    TextCommand
Undo -> case EditHistory -> [EditGroup]
historyUndo EditHistory
hist of
      EditGroup
g : [EditGroup]
rest ->
        let buf' :: TextBuffer
buf' = (TextBuffer -> StoredEdit -> TextBuffer)
-> TextBuffer -> [StoredEdit] -> TextBuffer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\TextBuffer
b StoredEdit
e -> TextEdit -> TextBuffer -> TextBuffer
TB.applyEdit (TextEdit -> TextEdit
TB.invertEdit (StoredEdit -> TextEdit
replayed StoredEdit
e)) TextBuffer
b) TextBuffer
buf (EditGroup -> [StoredEdit]
groupEdits EditGroup
g)
            (Cursor
a, Cursor
c) = EditGroup -> (Cursor, Cursor)
groupBefore EditGroup
g
         in TextBuffer -> Cursor -> EditHistory -> Editor
Editor (Cursor -> TextBuffer -> TextBuffer
TB.withCursor Cursor
c TextBuffer
buf') Cursor
a EditHistory
hist {historyUndo = rest, historyRedo = g : historyRedo hist, historyDepth = historyDepth hist - 1, historyOpen = False}
      [] -> Editor
ed
    TextCommand
Redo -> case EditHistory -> [EditGroup]
historyRedo EditHistory
hist of
      EditGroup
g : [EditGroup]
rest ->
        let buf' :: TextBuffer
buf' = (StoredEdit -> TextBuffer -> TextBuffer)
-> TextBuffer -> [StoredEdit] -> TextBuffer
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TextEdit -> TextBuffer -> TextBuffer
TB.applyEdit (TextEdit -> TextBuffer -> TextBuffer)
-> (StoredEdit -> TextEdit)
-> StoredEdit
-> TextBuffer
-> TextBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoredEdit -> TextEdit
replayed) TextBuffer
buf (EditGroup -> [StoredEdit]
groupEdits EditGroup
g)
            (Cursor
a, Cursor
c) = EditGroup -> (Cursor, Cursor)
groupAfter EditGroup
g
         in TextBuffer -> Cursor -> EditHistory -> Editor
Editor (Cursor -> TextBuffer -> TextBuffer
TB.withCursor Cursor
c TextBuffer
buf') Cursor
a EditHistory
hist {historyUndo = g : historyUndo hist, historyRedo = rest, historyDepth = historyDepth hist + 1, historyOpen = False}
      [] -> Editor
ed
    TextCommand
_ -> Editor
ed
  where
    cursor :: Cursor
cursor = TextBuffer -> Cursor
TB.getCursor TextBuffer
buf
    replayed :: StoredEdit -> TextEdit
replayed (StoredEdit Cursor
at ShortText
removed ShortText
inserted) = Cursor -> Text -> Text -> TextEdit
TextEdit Cursor
at (ShortText -> Text
TS.toText ShortText
removed) (ShortText -> Text
TS.toText ShortText
inserted)
    singleLine :: Text -> Text
singleLine = (if EditorMode -> Bool
modeMultiLine EditorMode
mode then Text -> Text
forall a. a -> a
id else (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TB.insertableText
    replaceSelection :: EditKind -> Text -> Editor
replaceSelection EditKind
kind Text
txt = EditKind -> TextEdit -> Editor
edit EditKind
kind (Text -> Cursor -> Cursor -> TextBuffer -> TextEdit
TB.replaceEdit Text
txt Cursor
anchor Cursor
cursor TextBuffer
buf)
    edit :: EditKind -> TextEdit -> Editor
edit EditKind
kind TextEdit
e
      | TextEdit -> Text
editRemoved TextEdit
e Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== TextEdit -> Text
editInserted TextEdit
e = Editor
ed
      | Bool
otherwise =
      let buf' :: TextBuffer
buf' = TextEdit -> TextBuffer -> TextBuffer
TB.applyEdit TextEdit
e TextBuffer
buf
          end :: Cursor
end = TextBuffer -> Cursor
TB.getCursor TextBuffer
buf'
       in TextBuffer -> Cursor -> EditHistory -> Editor
Editor TextBuffer
buf' Cursor
end (EditKind
-> (Cursor, Cursor)
-> TextEdit
-> (Cursor, Cursor)
-> EditHistory
-> EditHistory
record EditKind
kind (Cursor
anchor, Cursor
cursor) TextEdit
e (Cursor
end, Cursor
end) EditHistory
hist)
    motionTarget :: TextMotion -> Cursor
motionTarget = \case
      -- Deleting to the end of a line from its end takes the line break, so
      -- Ctrl+K keeps making progress.
      TextMotion
LineEnd | Text -> Int
T.length (Int -> TextBuffer -> Text
TB.lineAt (Cursor -> Int
cursorRow Cursor
cursor) TextBuffer
buf) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Cursor -> Int
cursorCol Cursor
cursor -> TextBuffer -> Cursor
TB.getCursor (TextBuffer -> TextBuffer
TB.moveRight TextBuffer
buf)
      TextMotion
motion -> TextBuffer -> Cursor
TB.getCursor (TextMotion -> TextBuffer
moveBuffer TextMotion
motion)
    moveBuffer :: TextMotion -> TextBuffer
moveBuffer = \case
      TextMotion
CharLeft -> TextBuffer -> TextBuffer
TB.moveLeft TextBuffer
buf
      TextMotion
CharRight -> TextBuffer -> TextBuffer
TB.moveRight TextBuffer
buf
      TextMotion
WordLeft -> TextBuffer -> TextBuffer
TB.moveWordLeft TextBuffer
buf
      TextMotion
WordRight -> TextBuffer -> TextBuffer
TB.moveWordRight TextBuffer
buf
      TextMotion
LineStart -> TextBuffer -> TextBuffer
TB.moveToBOL TextBuffer
buf
      TextMotion
LineEnd -> TextBuffer -> TextBuffer
TB.moveToEOL TextBuffer
buf
      TextMotion
LineUp -> if EditorMode -> Bool
modeMultiLine EditorMode
mode then TextBuffer -> TextBuffer
TB.moveUp TextBuffer
buf else TextBuffer
buf
      TextMotion
LineDown -> if EditorMode -> Bool
modeMultiLine EditorMode
mode then TextBuffer -> TextBuffer
TB.moveDown TextBuffer
buf else TextBuffer
buf
      TextMotion
DocumentStart -> TextBuffer -> TextBuffer
TB.moveToTop TextBuffer
buf
      TextMotion
DocumentEnd -> TextBuffer -> TextBuffer
TB.moveToBottom TextBuffer
buf

-- | 'runCommand', with the clipboard commands going through the context's
-- clipboard.
runCommandIO :: Context -> EditorMode -> TextCommand -> Editor -> IO Editor
runCommandIO :: Context -> EditorMode -> TextCommand -> Editor -> IO Editor
runCommandIO Context
ctx EditorMode
mode TextCommand
cmd Editor
ed =
  case TextCommand
cmd of
    TextCommand
Copy -> Editor
ed Editor -> IO () -> IO Editor
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO ()
copySelection
    TextCommand
Cut
      | EditorMode -> Bool
modeEditable EditorMode
mode Bool -> Bool -> Bool
&& EditorMode -> Bool
modeCopyable EditorMode
mode -> do
          IO ()
copySelection
          Editor -> IO Editor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EditorMode -> TextCommand -> Editor -> Editor
runCommand EditorMode
mode (TextMotion -> TextCommand
Delete TextMotion
CharRight) (if Editor -> Bool
hasSelection Editor
ed then Editor
ed else EditorMode -> TextCommand -> Editor -> Editor
runCommand EditorMode
mode TextCommand
SelectAll Editor
ed))
      | Bool
otherwise -> Editor -> IO Editor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Editor
ed
    TextCommand
Paste
      | EditorMode -> Bool
modeEditable EditorMode
mode -> do
          clip <- Context -> IO (Maybe Text)
ctxClipboardGet Context
ctx
          pure (maybe ed (\Text
txt -> EditorMode -> TextCommand -> Editor -> Editor
runCommand EditorMode
mode (Text -> TextCommand
InsertText Text
txt) Editor
ed) clip)
      | Bool
otherwise -> Editor -> IO Editor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Editor
ed
    TextCommand
_ -> Editor -> IO Editor
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EditorMode -> TextCommand -> Editor -> Editor
runCommand EditorMode
mode TextCommand
cmd Editor
ed)
  where
    -- Copy without a selection takes the whole field.
    copySelection :: IO ()
copySelection = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EditorMode -> Bool
modeCopyable EditorMode
mode) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let (Cursor
a, Cursor
c) = Editor -> (Cursor, Cursor)
editorSelection Editor
ed
          buf :: TextBuffer
buf = Editor -> TextBuffer
editorBuffer Editor
ed
          txt :: Text
txt = if Cursor
a Cursor -> Cursor -> Bool
forall a. Eq a => a -> a -> Bool
/= Cursor
c then Cursor -> Cursor -> TextBuffer -> Text
TB.selectedText Cursor
a Cursor
c TextBuffer
buf else TextBuffer -> Text
TB.toText TextBuffer
buf
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Text -> Bool
T.null Text
txt)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Context -> Text -> IO Bool
ctxClipboardSet Context
ctx Text
txt)

-- | The command a key runs. Ctrl or Alt turns character and deletion keys
-- into word motions, and Shift extends the selection.
keyCommand :: EditorMode -> Modifiers -> Key -> Maybe TextCommand
keyCommand :: EditorMode -> Modifiers -> Key -> Maybe TextCommand
keyCommand EditorMode
mode Modifiers
mods Key
key =
  case Key
key of
    Key
KeyBackspace -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> TextCommand
Delete (if Bool
word then TextMotion
WordLeft else TextMotion
CharLeft))
    Key
KeyDelete -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> TextCommand
Delete (if Bool
word then TextMotion
WordRight else TextMotion
CharRight))
    Key
KeyLeft -> TextMotion -> Maybe TextCommand
move (if Bool
word then TextMotion
WordLeft else TextMotion
CharLeft)
    Key
KeyRight -> TextMotion -> Maybe TextCommand
move (if Bool
word then TextMotion
WordRight else TextMotion
CharRight)
    Key
KeyHome -> TextMotion -> Maybe TextCommand
move (if Modifiers -> Bool
modCtrl Modifiers
mods Bool -> Bool -> Bool
&& Bool
multi then TextMotion
DocumentStart else TextMotion
LineStart)
    Key
KeyEnd -> TextMotion -> Maybe TextCommand
move (if Modifiers -> Bool
modCtrl Modifiers
mods Bool -> Bool -> Bool
&& Bool
multi then TextMotion
DocumentEnd else TextMotion
LineEnd)
    Key
KeyUp | Bool
multi Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
word -> TextMotion -> Maybe TextCommand
move TextMotion
LineUp
    Key
KeyDown | Bool
multi Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
word -> TextMotion -> Maybe TextCommand
move TextMotion
LineDown
    Key
KeyEnter | Bool
multi Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
word -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (Text -> TextCommand
InsertText Text
"\n")
    Key
_ -> Maybe TextCommand
forall a. Maybe a
Nothing
  where
    multi :: Bool
multi = EditorMode -> Bool
modeMultiLine EditorMode
mode
    word :: Bool
word = Modifiers -> Bool
modCtrl Modifiers
mods Bool -> Bool -> Bool
|| Modifiers -> Bool
modAlt Modifiers
mods
    move :: TextMotion -> Maybe TextCommand
move TextMotion
m = TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> Bool -> TextCommand
Move TextMotion
m (Modifiers -> Bool
modShift Modifiers
mods))

-- | This frame's typing and keys as commands, typed characters first. Ctrl
-- turns characters into shortcuts. Ctrl with Alt is AltGr on many layouts, so
-- its characters are typed like plain ones.
inputTextCommands :: EditorMode -> Input -> [TextCommand]
inputTextCommands :: EditorMode -> Input -> [TextCommand]
inputTextCommands EditorMode
mode Input
inp = (Char -> [TextCommand] -> [TextCommand])
-> [TextCommand] -> Text -> [TextCommand]
forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> [TextCommand] -> [TextCommand]
char [TextCommand]
keys (Input -> Text
inputChars Input
inp)
  where
    mods :: Modifiers
mods = Input -> Modifiers
inputModifiers Input
inp
    shortcut :: Bool
shortcut = Modifiers -> Bool
modCtrl Modifiers
mods Bool -> Bool -> Bool
&& Bool -> Bool
not (Modifiers -> Bool
modAlt Modifiers
mods)
    char :: Char -> [TextCommand] -> [TextCommand]
char Char
c [TextCommand]
rest
      | Bool
shortcut = [TextCommand]
-> (TextCommand -> [TextCommand])
-> Maybe TextCommand
-> [TextCommand]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TextCommand]
rest (TextCommand -> [TextCommand] -> [TextCommand]
forall a. a -> [a] -> [a]
: [TextCommand]
rest) (EditorMode -> Modifiers -> Char -> Maybe TextCommand
ctrlCharCommand EditorMode
mode Modifiers
mods Char
c)
      | Char -> Bool
isPrint Char
c = Text -> TextCommand
InsertText (Char -> Text
T.singleton Char
c) TextCommand -> [TextCommand] -> [TextCommand]
forall a. a -> [a] -> [a]
: [TextCommand]
rest
      | Bool
otherwise = [TextCommand]
rest
    keys :: [TextCommand]
keys = (Key -> [TextCommand] -> [TextCommand])
-> [TextCommand] -> SmallArray Key -> [TextCommand]
forall a b. (a -> b -> b) -> b -> SmallArray a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Key
k [TextCommand]
rest -> [TextCommand]
-> (TextCommand -> [TextCommand])
-> Maybe TextCommand
-> [TextCommand]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TextCommand]
rest (TextCommand -> [TextCommand] -> [TextCommand]
forall a. a -> [a] -> [a]
: [TextCommand]
rest) (EditorMode -> Modifiers -> Key -> Maybe TextCommand
keyCommand EditorMode
mode Modifiers
mods Key
k)) [] (Input -> SmallArray Key
inputKeys Input
inp)

-- | The command a character typed with Ctrl runs. Letters may arrive as the
-- letter or as their control code.
ctrlCharCommand :: EditorMode -> Modifiers -> Char -> Maybe TextCommand
ctrlCharCommand :: EditorMode -> Modifiers -> Char -> Maybe TextCommand
ctrlCharCommand EditorMode
mode Modifiers
mods Char
c =
  case Char -> Char
toLower Char
c of
    Char
'a' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
SelectAll
    Char
'c' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Copy
    Char
'x' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Cut
    Char
'v' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Paste
    Char
'z' | Modifiers -> Bool
modShift Modifiers
mods Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'Z' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Redo
    Char
'z' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Undo
    Char
'y' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Redo
    Char
'k' | Bool
multi -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> TextCommand
Delete TextMotion
LineEnd)
    Char
'u' | Bool
multi -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> TextCommand
Delete TextMotion
LineStart)
    Char
'e' | Bool
multi -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> Bool -> TextCommand
Move TextMotion
LineEnd Bool
False)
    Char
'\x01' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
SelectAll
    Char
'\x03' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Copy
    Char
'\x18' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Cut
    Char
'\x16' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Paste
    Char
'\x1a' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Undo
    Char
'\x19' -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just TextCommand
Redo
    Char
'\v' | Bool
multi -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> TextCommand
Delete TextMotion
LineEnd)
    Char
'\NAK' | Bool
multi -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> TextCommand
Delete TextMotion
LineStart)
    Char
'\ENQ' | Bool
multi -> TextCommand -> Maybe TextCommand
forall a. a -> Maybe a
Just (TextMotion -> Bool -> TextCommand
Move TextMotion
LineEnd Bool
False)
    Char
_ -> Maybe TextCommand
forall a. Maybe a
Nothing
  where
    multi :: Bool
multi = EditorMode -> Bool
modeMultiLine EditorMode
mode