{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
module Matterhorn.State.Editing
( requestSpellCheck
, editingKeybindings
, editingKeyHandlers
, messageEditingKeybindings
, toggleMultilineEditing
, invokeExternalEditor
, handlePaste
, handleInputSubmission
, getEditorContent
, handleEditingInput
, cancelAutocompleteOrReplyOrEdit
, replyToLatestMessage
, Direction(..)
, tabComplete
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick.Main ( invalidateCache, invalidateCacheEntry )
import Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent
, getEditContents, editContentsL )
import qualified Brick.Widgets.List as L
import qualified Codec.Binary.UTF8.Generic as UTF8
import Control.Arrow
import qualified Control.Concurrent.STM as STM
import qualified Data.ByteString as BS
import Data.Char ( isSpace )
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Maybe ( fromJust )
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Zipper as Z
import qualified Data.Text.Zipper.Generic.Words as Z
import Data.Time ( getCurrentTime )
import Graphics.Vty ( Event(..), Key(..) )
import Lens.Micro.Platform ( Lens', (%=), (.=), (.~), to, _Just )
import qualified System.Environment as Sys
import qualified System.Exit as Sys
import qualified System.IO as Sys
import qualified System.IO.Temp as Sys
import qualified System.Process as Sys
import Text.Aspell ( AspellResponse(..), mistakeWord, askAspell )
import Network.Mattermost.Types ( Post(..), ChannelId )
import Matterhorn.Config
import {-# SOURCE #-} Matterhorn.Command ( dispatchCommand )
import Matterhorn.InputHistory
import Matterhorn.Events.Keybindings
import Matterhorn.State.Common
import Matterhorn.State.Autocomplete
import Matterhorn.State.Attachments
import Matterhorn.State.Messages
import Matterhorn.Types hiding ( newState )
import Matterhorn.Types.Common ( sanitizeUserText' )
startMultilineEditing :: MH ()
startMultilineEditing = do
mh invalidateCache
csEditState.cedEphemeral.eesMultiline .= True
toggleMultilineEditing :: MH ()
toggleMultilineEditing = do
mh invalidateCache
csEditState.cedEphemeral.eesMultiline %= not
multiline <- use (csEditState.cedEphemeral.eesMultiline)
numLines <- use (csEditState.cedEditor.to getEditContents.to length)
when (not multiline && numLines > 1) resetAutocomplete
invokeExternalEditor :: MH ()
invokeExternalEditor = do
mEnv <- liftIO $ Sys.lookupEnv "EDITOR"
let editorProgram = maybe "vi" id mEnv
mhSuspendAndResume $ \ st -> do
Sys.withSystemTempFile "matterhorn_editor.md" $ \tmpFileName tmpFileHandle -> do
Sys.hPutStr tmpFileHandle $ T.unpack $ T.intercalate "\n" $
getEditContents $ st^.csEditState.cedEditor
Sys.hClose tmpFileHandle
status <- Sys.system (editorProgram <> " " <> tmpFileName)
case status of
Sys.ExitSuccess -> do
tmpBytes <- BS.readFile tmpFileName
case T.decodeUtf8' tmpBytes of
Left _ -> do
postErrorMessageIO "Failed to decode file contents as UTF-8" st
Right t -> do
let tmpLines = T.lines $ sanitizeUserText' t
return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing)
Sys.ExitFailure _ -> return st
handlePaste :: BS.ByteString -> MH ()
handlePaste bytes = do
let pasteStr = T.pack (UTF8.toString bytes)
csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr))
contents <- use (csEditState.cedEditor.to getEditContents)
case length contents > 1 of
True -> startMultilineEditing
False -> return ()
editingPermitted :: ChatState -> Bool
editingPermitted st =
(length (getEditContents $ st^.csEditState.cedEditor) == 1) ||
st^.csEditState.cedEphemeral.eesMultiline
messageEditingKeybindings :: KeyConfig -> KeyHandlerMap
messageEditingKeybindings kc =
let KeyHandlerMap m = editingKeybindings (csEditState.cedEditor) kc
in KeyHandlerMap $ M.map withUserTypingAction m
withUserTypingAction :: KeyHandler -> KeyHandler
withUserTypingAction kh =
kh { khHandler = newH }
where
oldH = khHandler kh
newH = oldH { kehHandler = newKEH }
oldKEH = kehHandler oldH
newKEH = oldKEH { ehAction = ehAction oldKEH >> sendUserTypingAction }
editingKeybindings :: Lens' ChatState (Editor T.Text Name) -> KeyConfig -> KeyHandlerMap
editingKeybindings editor = mkKeybindings $ editingKeyHandlers editor
editingKeyHandlers :: Lens' ChatState (Editor T.Text Name) -> [KeyEventHandler]
editingKeyHandlers editor =
[ mkKb EditorTransposeCharsEvent
"Transpose the final two characters"
(editor %= applyEdit Z.transposeChars)
, mkKb EditorBolEvent
"Go to the start of the current line"
(editor %= applyEdit Z.gotoBOL)
, mkKb EditorEolEvent
"Go to the end of the current line"
(editor %= applyEdit Z.gotoEOL)
, mkKb EditorDeleteCharacter
"Delete the character at the cursor"
(editor %= applyEdit Z.deleteChar)
, mkKb EditorKillToBolEvent
"Delete from the cursor to the start of the current line"
(editor %= applyEdit Z.killToBOL)
, mkKb EditorKillToEolEvent
"Kill the line to the right of the current position and copy it" $ do
z <- use (editor.editContentsL)
let restOfLine = Z.currentLine (Z.killToBOL z)
csEditState.cedYankBuffer .= restOfLine
editor %= applyEdit Z.killToEOL
, mkKb EditorNextCharEvent
"Move one character to the right"
(editor %= applyEdit Z.moveRight)
, mkKb EditorPrevCharEvent
"Move one character to the left"
(editor %= applyEdit Z.moveLeft)
, mkKb EditorNextWordEvent
"Move one word to the right"
(editor %= applyEdit Z.moveWordRight)
, mkKb EditorPrevWordEvent
"Move one word to the left"
(editor %= applyEdit Z.moveWordLeft)
, mkKb EditorDeletePrevWordEvent
"Delete the word to the left of the cursor" $ do
editor %= applyEdit Z.deletePrevWord
, mkKb EditorDeleteNextWordEvent
"Delete the word to the right of the cursor" $ do
editor %= applyEdit Z.deleteWord
, mkKb EditorHomeEvent
"Move the cursor to the beginning of the input" $ do
editor %= applyEdit gotoHome
, mkKb EditorEndEvent
"Move the cursor to the end of the input" $ do
editor %= applyEdit gotoEnd
, mkKb EditorYankEvent
"Paste the current buffer contents at the cursor" $ do
buf <- use (csEditState.cedYankBuffer)
editor %= applyEdit (Z.insertMany buf)
]
getEditorContent :: MH Text
getEditorContent = do
cmdLine <- use (csEditState.cedEditor)
let (line:rest) = getEditContents cmdLine
return $ T.intercalate "\n" $ line : rest
handleInputSubmission :: ChannelId -> Text -> MH ()
handleInputSubmission cId content = do
csEditState.cedEditor %= applyEdit Z.clearZipper
csEditState.cedInputHistory %= addHistoryEntry content cId
csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing
case T.uncons content of
Just ('/', cmd) ->
dispatchCommand cmd
_ -> do
attachments <- use (csEditState.cedAttachmentList.L.listElementsL)
mode <- use (csEditState.cedEditMode)
sendMessage cId mode content $ F.toList attachments
resetAutocomplete
resetAttachmentList
csEditState.cedEditMode .= NewPost
closingPunctuationMarks :: String
closingPunctuationMarks = ".,'\";:)]!?"
isSmartClosingPunctuation :: Event -> Bool
isSmartClosingPunctuation (EvKey (KChar c) []) = c `elem` closingPunctuationMarks
isSmartClosingPunctuation _ = False
handleEditingInput :: Event -> MH ()
handleEditingInput e = do
beforeLineCount <- use (csEditState.cedEditor.to getEditContents.to length)
smartBacktick <- use (csResources.crConfiguration.to configSmartBacktick)
let smartChars = "*`_"
st <- use id
csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing
smartEditing <- use (csResources.crConfiguration.to configSmartEditing)
justCompleted <- use (csEditState.cedJustCompleted)
conf <- use (csResources.crConfiguration)
let keyMap = editingKeybindings (csEditState.cedEditor) (configUserKeys conf)
case lookupKeybinding e keyMap of
Just kb | editingPermitted st -> (ehAction $ kehHandler $ khHandler kb)
_ -> do
case e of
EvKey KBS [] | (not $ editingPermitted st) ->
csEditState.cedEditor %= applyEdit Z.clearZipper
EvKey KBS [] | editingPermitted st && smartBacktick ->
let backspace = csEditState.cedEditor %= applyEdit Z.deletePrevChar
in case cursorAtOneOf smartChars (st^.csEditState.cedEditor) of
Nothing -> backspace
Just ch ->
if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csEditState.cedEditor) &&
(cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->
csEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar)
| otherwise -> backspace
EvKey (KChar ch) []
| editingPermitted st && smartBacktick && ch `elem` smartChars ->
let doInsertChar = do
csEditState.cedEditor %= applyEdit (Z.insertChar ch)
sendUserTypingAction
curLine = Z.currentLine $ st^.csEditState.cedEditor.editContentsL
in if | (cursorIsAtEnd $ st^.csEditState.cedEditor) &&
curLine == "``" &&
ch == '`' -> do
csEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch))
csEditState.cedEphemeral.eesMultiline .= True
| (editorEmpty $ st^.csEditState.cedEditor) ||
((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) &&
(cursorIsAtEnd $ st^.csEditState.cedEditor)) ->
csEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft)
| (cursorAtChar ch $ st^.csEditState.cedEditor) &&
(cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->
csEditState.cedEditor %= applyEdit Z.moveRight
| otherwise -> doInsertChar
| editingPermitted st -> do
when (smartEditing && justCompleted && isSmartClosingPunctuation e) $
csEditState.cedEditor %= applyEdit Z.deletePrevChar
csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' $ T.singleton ch))
sendUserTypingAction
_ | editingPermitted st -> do
mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent e
sendUserTypingAction
| otherwise -> return ()
let ctx = AutocompleteContext { autocompleteManual = False
, autocompleteFirstMatch = False
}
checkForAutocompletion ctx
liftIO $ resetSpellCheckTimer $ st^.csEditState
afterLineCount <- use (csEditState.cedEditor.to getEditContents.to length)
isMultiline <- use (csEditState.cedEphemeral.eesMultiline)
isPreviewing <- use csShowMessagePreview
when (beforeLineCount /= afterLineCount && isMultiline && isPreviewing) $ do
cId <- use csCurrentChannelId
mh $ invalidateCacheEntry $ ChannelMessages cId
when justCompleted $
csEditState.cedJustCompleted .= False
sendUserTypingAction :: MH ()
sendUserTypingAction = do
st <- use id
when (configShowTypingIndicator (st^.csResources.crConfiguration)) $
case st^.csConnectionStatus of
Connected -> do
let pId = case st^.csEditState.cedEditMode of
Replying _ post -> Just $ postId post
_ -> Nothing
liftIO $ do
now <- getCurrentTime
let action = UserTyping now (st^.csCurrentChannelId) pId
STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action
Disconnected -> return ()
requestSpellCheck :: MH ()
requestSpellCheck = do
st <- use id
case st^.csEditState.cedSpellChecker of
Nothing -> return ()
Just (checker, _) -> do
contents <- getEditContents <$> use (csEditState.cedEditor)
doAsyncWith Preempt $ do
let query = concat <$> mapM (askAspell checker) contents
postMistakes :: [AspellResponse] -> MH ()
postMistakes responses = do
let getMistakes AllCorrect = []
getMistakes (Mistakes ms) = mistakeWord <$> ms
allMistakes = S.fromList $ concat $ getMistakes <$> responses
csEditState.cedMisspellings .= allMistakes
tryMM query (return . Just . postMistakes)
editorEmpty :: Editor Text a -> Bool
editorEmpty e = cursorIsAtEnd e &&
cursorIsAtBeginning e
cursorIsAtEnd :: Editor Text a -> Bool
cursorIsAtEnd e =
let col = snd $ Z.cursorPosition z
curLine = Z.currentLine z
z = e^.editContentsL
in col == T.length curLine
cursorIsAtBeginning :: Editor Text a -> Bool
cursorIsAtBeginning e =
let col = snd $ Z.cursorPosition z
z = e^.editContentsL
in col == 0
cursorAtOneOf :: [Char] -> Editor Text a -> Maybe Char
cursorAtOneOf [] _ = Nothing
cursorAtOneOf (c:cs) e =
if cursorAtChar c e
then Just c
else cursorAtOneOf cs e
cursorAtChar :: Char -> Editor Text a -> Bool
cursorAtChar ch e =
let col = snd $ Z.cursorPosition z
curLine = Z.currentLine z
z = e^.editContentsL
in (T.singleton ch) `T.isPrefixOf` T.drop col curLine
gotoHome :: Z.TextZipper Text -> Z.TextZipper Text
gotoHome = Z.moveCursor (0, 0)
gotoEnd :: Z.TextZipper Text -> Z.TextZipper Text
gotoEnd z =
let zLines = Z.getText z
numLines = length zLines
lastLineLength = T.length $ last zLines
in if numLines > 0
then Z.moveCursor (numLines - 1, lastLineLength) z
else z
cancelAutocompleteOrReplyOrEdit :: MH ()
cancelAutocompleteOrReplyOrEdit = do
cId <- use csCurrentChannelId
mh $ invalidateCacheEntry $ ChannelMessages cId
ac <- use (csEditState.cedAutocomplete)
case ac of
Just _ -> do
resetAutocomplete
Nothing -> do
mode <- use (csEditState.cedEditMode)
case mode of
NewPost -> return ()
_ -> do
csEditState.cedEditMode .= NewPost
csEditState.cedEditor %= applyEdit Z.clearZipper
resetAttachmentList
replyToLatestMessage :: MH ()
replyToLatestMessage = do
msgs <- use (csCurrentChannel . ccContents . cdMessages)
case findLatestUserMessage isReplyable msgs of
Just msg | isReplyable msg ->
do rootMsg <- getReplyRootMessage msg
setMode Main
cId <- use csCurrentChannelId
mh $ invalidateCacheEntry $ ChannelMessages cId
csEditState.cedEditMode .= Replying rootMsg (fromJust $ rootMsg^.mOriginalPost)
_ -> return ()
data Direction = Forwards | Backwards
tabComplete :: Direction -> MH ()
tabComplete dir = do
let transform list =
let len = list^.L.listElementsL.to length
in case dir of
Forwards ->
if (L.listSelected list == Just (len - 1)) ||
(L.listSelected list == Nothing && len > 0)
then L.listMoveTo 0 list
else L.listMoveBy 1 list
Backwards ->
if (L.listSelected list == Just 0) ||
(L.listSelected list == Nothing && len > 0)
then L.listMoveTo (len - 1) list
else L.listMoveBy (-1) list
csEditState.cedAutocomplete._Just.acCompletionList %= transform
mac <- use (csEditState.cedAutocomplete)
case mac of
Nothing -> do
let ctx = AutocompleteContext { autocompleteManual = True
, autocompleteFirstMatch = True
}
checkForAutocompletion ctx
Just ac -> do
case ac^.acCompletionList.to L.listSelectedElement of
Nothing -> return ()
Just (_, alternative) -> do
let replacement = autocompleteAlternativeReplacement alternative
maybeEndOfWord z =
if maybe True isSpace (Z.currentChar z)
then z
else Z.moveWordRight z
csEditState.cedEditor %=
applyEdit (Z.insertChar ' ' . Z.insertMany replacement . Z.deletePrevWord .
maybeEndOfWord)
csEditState.cedJustCompleted .= True
when (ac^.acCompletionList.to L.listElements.to length == 1) resetAutocomplete