{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Simplex.Chat.Terminal.Input where

import Control.Applicative (optional, (<|>))
import Control.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
import Control.Monad.Except
import Control.Monad.Reader
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (second)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlpha, isAlphaNum, isAscii)
import Data.Either (fromRight)
import Data.List (dropWhileEnd, foldl', sort)
import Data.Maybe (isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Database.SQLite.Simple (Only (..))
import qualified Database.SQLite.Simple as SQL
import Database.SQLite.Simple.QQ (sql)
import GHC.Weak (deRefWeak)
import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Styled
import Simplex.Chat.Terminal.Output
import Simplex.Chat.Types (User (..))
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, withTransaction)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (catchAll_, safeDecodeUtf8, whenM)
import System.Exit (exitSuccess)
import System.Terminal hiding (insertChars)
import UnliftIO.STM

getKey :: MonadTerminal m => m (Key, Modifiers)
getKey =
  flush >> awaitEvent >>= \case
    Left Interrupt -> liftIO exitSuccess
    Right (KeyEvent key ms) -> pure (key, ms)
    _ -> getKey

runInputLoop :: ChatTerminal -> ChatController -> IO ()
runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
  s <- atomically . readTBQueue $ inputQ cc
  let bs = encodeUtf8 $ T.pack s
      cmd = parseChatCommand bs
  unless (isMessage cmd) $ echo s
  r <- runReaderT (execChatCommand bs) cc
  case r of
    CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
    CRChatError _ _ -> when (isMessage cmd) $ echo s
    _ -> pure ()
  printRespToTerminal ct cc False r
  startLiveMessage cmd r
  where
    echo s = printToTerminal ct [plain s]
    isMessage = \case
      Right SendMessage {} -> True
      Right SendLiveMessage {} -> True
      Right SendFile {} -> True
      Right SendMessageQuote {} -> True
      Right SendGroupMessageQuote {} -> True
      Right SendMessageBroadcast {} -> True
      _ -> False
    startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO ()
    startLiveMessage (Right (SendLiveMessage sendName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do
      whenM (isNothing <$> readTVarIO liveMessageState) $ do
        let s = T.unpack msg
            int = case cType of SCTGroup -> 5000000; _ -> 3000000 :: Int
        liveThreadId <- mkWeakThreadId =<< runLiveMessage int `forkFinally` const (atomically $ writeTVar liveMessageState Nothing)
        promptThreadId <- mkWeakThreadId =<< forkIO blinkLivePrompt
        atomically $ do
          let lm = LiveMessage {sendName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId}
          writeTVar liveMessageState (Just lm)
          modifyTVar termState $ \ts -> ts {inputString = s, inputPosition = length s, inputPrompt = liveInputPrompt lm}
      where
        liveInputPrompt LiveMessage {sendName = n, livePrompt} =
          "> " <> sendNameStr n <> " [" <> (if livePrompt then "LIVE" else "    ") <> "] "
        runLiveMessage :: Int -> IO ()
        runLiveMessage int = do
          threadDelay int
          TerminalState {inputString = s} <- readTVarIO termState
          readTVarIO liveMessageState
            >>= mapM_ (\lm -> updateLiveMessage s lm >> runLiveMessage int)
        blinkLivePrompt = readTVarIO liveMessageState >>= mapM_ updateLivePrompt
          where
            updateLivePrompt lm = do
              atomically $ updatePrompt lm
              updateInputView ct
              threadDelay 1000000
              blinkLivePrompt
            updatePrompt lm = do
              writeTVar liveMessageState $ Just lm {livePrompt = not $ livePrompt lm}
              modifyTVar termState (\ts -> ts {inputPrompt = liveInputPrompt lm})
        liveMessageToSend t LiveMessage {sentMsg, typedMsg} =
          let s = if t /= typedMsg then truncateToWords t else t
           in if s /= sentMsg then Just s else Nothing
        updateLiveMessage typedMsg lm = case liveMessageToSend typedMsg lm of
          Just sentMsg ->
            sendUpdatedLiveMessage cc sentMsg lm True >>= \case
              CRChatItemUpdated {} -> setLiveMessage lm {sentMsg, typedMsg}
              _ -> do
                -- TODO print error
                setLiveMessage lm {typedMsg}
          _ -> setLiveMessage lm {typedMsg}
        setLiveMessage :: LiveMessage -> IO ()
        setLiveMessage = atomically . writeTVar liveMessageState . Just
        truncateToWords = fst . foldl' acc ("", "")
          where
            acc (s, w) c
              | isAlphaNum c = (s, c : w)
              | otherwise = (s <> reverse (c : w), "")
    startLiveMessage _ _ = pure ()

sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO ChatResponse
sendUpdatedLiveMessage cc sentMsg LiveMessage {sendName, chatItemId} live = do
  let cmd = UpdateLiveMessage sendName chatItemId live $ T.pack sentMsg
  either (CRChatCmdError Nothing) id <$> runExceptT (processChatCommand cmd) `runReaderT` cc

runTerminalInput :: ChatTerminal -> ChatController -> IO ()
runTerminalInput ct cc = withChatTerm ct $ do
  updateInput ct
  receiveFromTTY cc ct

receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} =
  forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
  where
    processKey :: (Key, Modifiers) -> IO ()
    processKey key = case key of
      (EnterKey, ms)
        | ms == mempty -> submit False
        | ms == altKey -> submit True
        | otherwise -> pure ()
      (CharKey c, ms)
        | (c == 'l' || c == 'L') && ms == ctrlKey -> submit True
        | otherwise -> update key
      _ -> update key
    submit live = do
      ts <- readTVarIO termState
      isLive <- isJust <$> readTVarIO liveMessageState
      when (inputString ts /= "" || isLive) $
        atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
    update key = do
      ac <- readTVarIO activeTo
      live <- isJust <$> readTVarIO liveMessageState
      ts <- readTVarIO termState
      user_ <- readTVarIO currentUser
      ts' <- updateTermState user_ chatStore ac live (width termSize) key ts
      atomically $ writeTVar termState $! ts'

    endLiveMessage :: String -> LiveMessage -> IO ()
    endLiveMessage sentMsg lm = do
      kill liveThreadId
      kill promptThreadId
      atomically $ writeTVar liveMessageState Nothing
      r <- sendUpdatedLiveMessage cc sentMsg lm False
      printRespToTerminal ct cc False r
      where
        kill sel = deRefWeak (sel lm) >>= mapM_ killThread

    submitInput :: Bool -> TerminalState -> STM (Maybe (String, LiveMessage))
    submitInput live ts = do
      let s = inputString ts
      lm_ <- readTVar liveMessageState
      case lm_ of
        Just LiveMessage {sendName}
          | live -> do
            writeTVar termState ts' {previousInput}
            writeTBQueue inputQ $ "/live " <> sendNameStr sendName
          | otherwise ->
            writeTVar termState ts' {inputPrompt = "> ", previousInput}
          where
            previousInput = sendNameStr sendName <> " " <> s
        _
          | live -> when (isSend s) $ do
            writeTVar termState ts' {previousInput = s}
            writeTBQueue inputQ $ "/live " <> s
          | otherwise -> do
            writeTVar termState ts' {inputPrompt = "> ", previousInput = s}
            writeTBQueue inputQ s
      pure $ (s,) <$> lm_
      where
        isSend s = length s > 1 && (head s == '@' || head s == '#')
        ts' = ts {inputString = "", inputPosition = 0, autoComplete = mkAutoComplete}

data AutoComplete
  = ACContact Text
  | ACContactRequest Text
  | ACMember Text Text
  | ACGroup Text
  | ACCommand Text
  | ACNone

updateTermState :: Maybe User -> SQLiteStore -> ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
  CharKey c
    | ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
    | ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
    | ms == altKey && c == 'f' -> pure $ setPosition nextWordPos
    | otherwise -> pure ts
  TabKey -> do
    (pfx, vs) <- autoCompleteVariants user_
    let sv = acShowVariants acp
        sv'
          | not (acTabPressed acp) = if null pfx || sv /= SVNone then SVSome else SVNone
          | sv == SVNone = SVSome
          | sv == SVSome && length vs > 4 = SVAll
          | otherwise = SVNone
        acp' = acp {acVariants = vs, acInputString = s, acShowVariants = sv', acTabPressed = True}
    pure $ (insertChars pfx) {autoComplete = acp'}
  BackspaceKey -> pure backDeleteChar
  DeleteKey -> pure deleteChar
  HomeKey -> pure $ setPosition 0
  EndKey -> pure $ setPosition $ length s
  ArrowKey d -> pure $ case d of
    Leftwards -> setPosition leftPos
    Rightwards -> setPosition rightPos
    Upwards
      | ms == mempty && null s -> let s' = upArrowCmd $ previousInput ts in ts' (s', length s')
      | ms == mempty -> let p' = p - tw in if p' > 0 then setPosition p' else ts
      | otherwise -> ts
    Downwards
      | ms == mempty -> let p' = p + tw in if p' <= length s then setPosition p' else ts
      | otherwise -> ts
  _ -> pure ts
  where
    autoCompleteVariants Nothing = pure ("", [charsWithContact "    "])
    autoCompleteVariants (Just User {userId, userContactId}) =
      getAutoCompleteChars $ fromRight ACNone $ A.parseOnly autoCompleteP $ encodeUtf8 $ T.pack s
      where
        autoCompleteP =
          A.choice
            [ ACContact <$> (contactPfx *> displayName <* A.endOfInput),
              ACContactRequest <$> (contactReqPfx *> displayName <* A.endOfInput),
              ACMember <$> (groupMemberPfx *> displayName) <* A.space <* optional (A.char '@') <*> displayName <* A.endOfInput,
              ACGroup <$> (groupPfx *> displayName <* A.endOfInput),
              ACCommand . safeDecodeUtf8 <$> ((<>) <$> ("/" *> alphaP) <*> (B.cons <$> A.space <*> alphaP <|> "")) <* A.endOfInput
            ]
        displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ') <|> "")
        refChar c = c > ' ' && c /= '#' && c /= '@'
        alphaP = A.takeWhile $ \c -> isAscii c && isAlpha c
        contactPfx =
          A.choice $
            ops '@' [">>", ">", "!", "\\"]
              <> cmd '@' ["t", "tail", "?", "search", "set voice", "set delete", "set disappear"]
              <> cmd_ '@' ["i ", "info ", "f ", "file ", "clear", "d ", "delete ", "code ", "verify "]
              <> ["@"]
        contactReqPfx = A.choice $ cmd_ '@' ["ac", "accept", "rc", "reject"]
        groupPfx =
          A.choice $
            ops '#' [">", "!", "\\\\", "\\"]
              <> cmd '#' ["t", "tail", "?", "search", "i", "info", "f", "file", "clear", "d", "delete", "code", "verify", "set voice", "set delete", "set disappear", "set direct"]
              <> cmd_ '#' ["a", "add", "j", "join", "rm", "remove", "l", "leave", "ms", "members", "mr", "member role"]
              <> ["#"]
        groupMemberPfx =
          A.choice $
            ops '#' [">", "\\\\"]
              <> cmd '#' ["i", "info", "code", "verify"]
              <> cmd_ '#' ["rm", "remove", "l", "leave", "mr", "member role"]
        ops c = map (<* (optional A.space <* A.char c))
        cmd c = map $ \t -> A.char '/' *> t <* A.space <* A.char c
        cmd_ c = map $ \t -> A.char '/' *> t <* A.space <* optional (A.char c)
        getAutoCompleteChars = \case
          ACContact pfx -> common pfx <$> getContactSfxs pfx
          ACContactRequest pfx -> common pfx <$> getNameSfxs "contact_requests" pfx
          ACGroup pfx -> common pfx <$> getNameSfxs "groups" pfx
          ACMember gName pfx -> common pfx <$> getMemberNameSfxs gName pfx
          ACCommand pfx -> pure $ second (map ('/' :)) $ common pfx $ hasPfx pfx commands
          ACNone -> pure ("", [charsWithContact ""])
          where
            getMemberNameSfxs gName pfx =
              getNameSfxs_
                pfx
                (userId, userContactId, gName, pfx <> "%")
                [sql|
                  SELECT m.local_display_name
                  FROM group_members m
                  JOIN groups g USING (group_id)
                  WHERE g.user_id = ?
                    AND (m.contact_id IS NULL OR m.contact_id != ?)
                    AND g.local_display_name = ?
                    AND m.local_display_name LIKE ?
                |]
            getContactSfxs pfx =
              getNameSfxs_
                pfx
                (userId, pfx <> "%")
                "SELECT local_display_name FROM contacts WHERE is_user = 0 AND user_id = ? AND local_display_name LIKE ?"
            getNameSfxs table pfx =
              getNameSfxs_ pfx (userId, pfx <> "%") $
                "SELECT local_display_name FROM " <> table <> " WHERE user_id = ? AND local_display_name LIKE ?"
            getNameSfxs_ :: SQL.ToRow p => Text -> p -> SQL.Query -> IO [String]
            getNameSfxs_ pfx ps q =
              withTransaction st (\db -> hasPfx pfx . map fromOnly <$> DB.query db q ps) `catchAll_` pure []
            commands =
              ["connect", "search", "tail", "info", "clear", "delete", "code", "verify"]
                <> ["file", "freceive", "fcancel", "fstatus", "fforward", "image", "image_forward"]
                <> ["address", "delete_address", "show_address", "auto_accept", "accept @", "reject @"]
                <> ["group", "groups", "members #", "member role #", "add #", "join #", "remove #", "leave #"]
                <> ["create link #", "set link role #", "delete link #", "show link #"]
                <> ["set voice", "set delete", "set direct #", "set disappear", "mute", "unmute"]
                <> ["create user", "profile", "users", "user", "mute user", "unmute user", "hide user", "unhide user", "delete user"]
                <> ["chats", "contacts", "help", "markdown", "quit", "db export", "db encrypt", "db decrypt", "db key"]
            hasPfx pfx = map T.unpack . sort . filter (pfx `T.isPrefixOf`)
            common pfx xs = (commonPrefix $ map (drop $ T.length pfx) xs, xs)
    commonPrefix = \case
      x : xs -> foldl go x xs
      _ -> ""
      where
        go (c : cs) (c' : cs')
          | c == c' = c : go cs cs'
          | otherwise = ""
        go _ _ = ""
    charsWithContact cs
      | live = cs
      | null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
        contactPrefix <> cs
      | (s == ">" || s == "\\" || s == "!") && cs == " " =
        cs <> contactPrefix
      | otherwise = cs
    insertChars = ts' . if p >= length s then append else insert
    append cs = let s' = s <> cs in (s', length s')
    insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
    contactPrefix = case ac of
      ActiveNone -> ""
      ActiveC c -> "@" <> T.unpack c <> " "
      ActiveG g -> "#" <> T.unpack g <> " "
    backDeleteChar
      | p == 0 || null s = ts
      | p >= length s = ts' (init s, length s - 1)
      | otherwise = let (b, a) = splitAt p s in ts' (init b <> a, p - 1)
    deleteChar
      | p >= length s || null s = ts
      | p == 0 = ts' (tail s, 0)
      | otherwise = let (b, a) = splitAt p s in ts' (b <> tail a, p)
    leftPos
      | ms == mempty = max 0 (p - 1)
      | ms == shiftKey = 0
      | ms == ctrlKey = prevWordPos
      | ms == altKey = prevWordPos
      | otherwise = p
    rightPos
      | ms == mempty = min (length s) (p + 1)
      | ms == shiftKey = length s
      | ms == ctrlKey = nextWordPos
      | ms == altKey = nextWordPos
      | otherwise = p
    upArrowCmd inp = case parseChatCommand . encodeUtf8 $ T.pack inp of
      Left _ -> inp
      Right cmd -> case cmd of
        SendMessage {} -> "! " <> inp
        SendMessageQuote {contactName, message} -> T.unpack $ "! @" <> contactName <> " " <> message
        SendGroupMessageQuote {groupName, message} -> T.unpack $ "! #" <> groupName <> " " <> message
        _ -> inp
    setPosition p' = ts' (s, p')
    prevWordPos
      | p == 0 || null s = p
      | otherwise =
        let before = take p s
            beforeWord = dropWhileEnd (/= ' ') $ dropWhileEnd (== ' ') before
         in max 0 $ p - length before + length beforeWord
    nextWordPos
      | p >= length s || null s = p
      | otherwise =
        let after = drop p s
            afterWord = dropWhile (/= ' ') $ dropWhile (== ' ') after
         in min (length s) $ p + length after - length afterWord
    ts' (s', p') = ts {inputString = s', inputPosition = p', autoComplete = acp {acTabPressed = False}}