Internal.hs

{-# LANGUAGE OverloadedStrings #-}

module System.Terminal.Emulator.Parsing.Internal where

import Control.Applicative ((<|>))
import Data.Attoparsec.Text
import Data.Char (isDigit)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import qualified Data.Vector as V
import System.Terminal.Emulator.DECPrivateMode (intToDECPrivateMode)
import System.Terminal.Emulator.Parsing.Types (ControlSequenceIntroducer (..), DeviceStatusReport (..), EraseInDisplayParam (..), EraseInLineParam (..), EscapeSequence (..), Mode (..), OperatingSystemCommand (..), SendDeviceAttributesSecondary (RequestTerminalIdentificationCode), SingleCharacterFunction (..), TermAtom (..), WindowManipulation (..), codeToSGR)
import Prelude hiding (takeWhile)

parseTermAtom :: Parser TermAtom
parseTermAtom =
  parseVisibleChar <|> parseControl

parseVisibleChar :: Parser TermAtom
parseVisibleChar = TermAtom_VisibleChar <$> satisfy (not . isControl)

-- | This parser always succeeds
parseControl :: Parser TermAtom
parseControl = do
  c <- anyChar
  if c == '\ESC'
    then parseEscape
    else pure $ case singleCharacterFunction c of
      Nothing -> TermAtom_SingleCharacterFunctionUnknown c
      Just f -> TermAtom_SingleCharacterFunction f

singleCharacterFunction :: Char -> Maybe SingleCharacterFunction
singleCharacterFunction '\a' = Just Control_Bell
singleCharacterFunction '\b' = Just Control_Backspace
singleCharacterFunction '\r' = Just Control_CarriageReturn
singleCharacterFunction '\ENQ' = Just Control_ReturnTerminalStatus
singleCharacterFunction '\f' = Just Control_FormFeed
singleCharacterFunction '\n' = Just Control_LineFeed
singleCharacterFunction '\SI' = Just Control_SwitchToStandardCharacterSet
singleCharacterFunction '\SO' = Just Control_SwitchToAlternateCharacterSet
singleCharacterFunction '\t' = Just Control_Tab
singleCharacterFunction '\v' = Just Control_VerticalTab
singleCharacterFunction _ = Nothing

-- | This parser always succeeds
parseEscape :: Parser TermAtom
parseEscape = do
  c <- anyChar
  case c of
    '[' -> handleCsi
    ']' -> handleOsc
    '(' -> handleSetG0CharacterSet
    _ -> handleSingle c
  where
    handleCsi :: Parser TermAtom
    handleCsi = do
      csiInput <- parseControlSequenceIntroducer
      pure $ case processControlSequenceIntroducer csiInput of
        Nothing -> case processOtherControlSequenceIntroducer csiInput of
          Nothing -> TermAtom_EscapeSequenceUnknown (renderCsi csiInput)
          Just csi -> TermAtom_EscapeSequence (Esc_CSI csi)
        Just csi -> TermAtom_EscapeSequence (Esc_CSI csi)

    handleOsc :: Parser TermAtom
    handleOsc = do
      oscInput <- parseOperatingSystemCommand
      pure $ case processOperatingSystemCommand oscInput of
        Nothing -> TermAtom_EscapeSequenceUnknown (renderOsc oscInput)
        Just osc -> TermAtom_EscapeSequence (Esc_OSC osc)

    handleSingle :: Char -> Parser TermAtom
    handleSingle c = pure $ case singleCharacterEscapeSequence c of
      Just e -> TermAtom_EscapeSequence e
      Nothing -> TermAtom_EscapeSequenceUnknown ("\ESC" <> T.singleton c)

    handleSetG0CharacterSet :: Parser TermAtom
    handleSetG0CharacterSet =
      ( choice
          [ string "A",
            string "B",
            string "C",
            string "5",
            string "H",
            string "7",
            string "K",
            string "Q",
            string "9",
            string "R",
            string "f",
            string "Y",
            string "Z",
            string "4",
            string "\">",
            string "%2",
            string "%6",
            string "%=",
            string "=",
            string "`",
            string "E",
            string "6",
            string "0",
            string "<",
            string ">",
            string "\"4",
            string "\"?",
            string "%0",
            string "%5",
            string "&4",
            string "%3",
            string "&5"
          ]
          >>= pure . TermAtom_EscapeSequence . ESC_SetG0CharacterSet
      )
        <|> ( anyChar >>= \c ->
                pure (TermAtom_EscapeSequenceUnknown ("\ESC(" <> T.singleton c))
            )

-----------------------------------------------------------------------
-- CSI (Control Sequence Introducer) sequences
-----------------------------------------------------------------------

data ControlSequenceIntroducerInput = ControlSequenceIntroducerInput !Text
  deriving (Show, Eq)

data ControlSequenceIntroducerComponents
  = ControlSequenceIntroducerComponents
      !Bool
      -- ^ Private?
      !(NonEmpty Int)
      -- ^ Args
      !Char
      -- ^ Mode
  deriving (Show, Eq)

-- | Should be run after reading the sequence @ESC [@
--
-- This parser always succeeds
parseControlSequenceIntroducer :: Parser ControlSequenceIntroducerInput
parseControlSequenceIntroducer = do
  str <- takeTill ((`between` (0x40, 0x7E)) . fromEnum)
  c <- anyChar
  pure (ControlSequenceIntroducerInput ((str) <> T.singleton c))

parseControlSequenceIntroducerComponents :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducerComponents
parseControlSequenceIntroducerComponents (ControlSequenceIntroducerInput str) =
  case parseOnly (parser <* endOfInput) str of
    Left _ -> Nothing
    Right val -> Just val
  where
    parser :: Parser ControlSequenceIntroducerComponents
    parser = do
      private <- option False (char '?' >> pure True)
      first <- peekChar'
      args <-
        if isDigit first || first == ';'
          then sepBy (option 0 decimal) (char ';')
          else pure []
      mode <- anyChar
      pure (ControlSequenceIntroducerComponents private (listToNonEmpty 0 args) mode)

listToNonEmpty :: a -> [a] -> NonEmpty a
listToNonEmpty def [] = def :| []
listToNonEmpty _ (x : xs) = x :| xs

processControlSequenceIntroducerComponents :: ControlSequenceIntroducerComponents -> Maybe ControlSequenceIntroducer
processControlSequenceIntroducerComponents (ControlSequenceIntroducerComponents False args mode) = parseCsi mode args
processControlSequenceIntroducerComponents (ControlSequenceIntroducerComponents True args mode) = parsePrivCsi mode args

changeZero :: Int -> Int -> Int
changeZero toVal 0 = toVal
changeZero _ val = val

headChangeZero :: Int -> NonEmpty Int -> Int
headChangeZero toVal args = changeZero toVal (NE.head args)

parseCsi :: Char -> NonEmpty Int -> Maybe ControlSequenceIntroducer
parseCsi mode args = case mode of
  'A' -> Just (CSI_CursorUp (headChangeZero 1 args))
  'B' -> Just (CSI_CursorDown (headChangeZero 1 args))
  'C' -> Just (CSI_CursorForward (headChangeZero 1 args))
  'D' -> Just (CSI_CursorBack (headChangeZero 1 args))
  'K' ->
    CSI_EraseInLine <$> case NE.head args of
      0 -> Just ClearFromCursorToEndOfLine
      1 -> Just ClearFromCursorToBeginningOfLine
      2 -> Just ClearEntireLine
      _ -> Nothing
  '@' -> Just (CSI_InsertBlankCharacters (headChangeZero 1 args))
  'P' -> Just (CSI_DeleteChars (headChangeZero 1 args))
  'G' -> Just (CSI_CursorCharacterAbsolute (headChangeZero 1 args))
  'H' ->
    let (row, col) = case args of
          r :| [] -> (r, 0)
          r :| (c : _) -> (r, c)
     in Just (CSI_CursorPosition (changeZero 1 row) (changeZero 1 col))
  'J' -> case NE.head args of
    0 -> Just (CSI_EraseInDisplay EraseBelow)
    1 -> Just (CSI_EraseInDisplay EraseAbove)
    2 -> Just (CSI_EraseInDisplay EraseAll)
    3 -> Just (CSI_EraseInDisplay EraseSavedLines)
    _ -> Nothing
  'L' -> Just (CSI_InsertBlankLines (headChangeZero 1 args))
  'M' -> Just (CSI_DeleteLines (headChangeZero 1 args))
  'S' -> Just (CSI_ScrollUp (headChangeZero 1 args))
  'T' -> Just (CSI_ScrollDown (headChangeZero 1 args))
  'X' -> Just (CSI_EraseCharacters (headChangeZero 1 args))
  '`' -> Just (CSI_CharacterPositionAbsolute (headChangeZero 1 args))
  'a' -> Just (CSI_CharacterPositionRelative (headChangeZero 1 args))
  'c' -> case args of
    0 :| [] -> Just CSI_SendDeviceAttributes
    _ -> Nothing
  'd' -> Just (CSI_LinePositionAbsolute (headChangeZero 1 args))
  'e' -> Just (CSI_LinePositionRelative (headChangeZero 1 args))
  'f' ->
    let (row, col) = case args of
          r :| [] -> (r, 0)
          r :| (c : _) -> (r, c)
     in Just (CSI_HorizontalVerticalPosition (changeZero 1 row) (changeZero 1 col))
  't' -> case args of
    22 :| 0 : _ -> Just (CSI_WindowManipulation SaveIconAndWindowTitleOnStack)
    23 :| 0 : _ -> Just (CSI_WindowManipulation RestoreIconAndWindowTitleOnStack)
    _ -> Nothing
  'h' -> case args of
    2 :| [] -> Just (CSI_SetMode KeyboardActionMode)
    4 :| [] -> Just (CSI_SetMode InsertReplaceMode)
    12 :| [] -> Just (CSI_SetMode SendReceive)
    20 :| [] -> Just (CSI_SetMode AutomaticNewlineNormalLinefeed)
    _ -> Nothing
  'l' -> case args of
    2 :| [] -> Just (CSI_ResetMode KeyboardActionMode)
    4 :| [] -> Just (CSI_ResetMode InsertReplaceMode)
    12 :| [] -> Just (CSI_ResetMode SendReceive)
    20 :| [] -> Just (CSI_ResetMode AutomaticNewlineNormalLinefeed)
    _ -> Nothing
  'n' -> case NE.head args of
    5 -> Just (CSI_DeviceStatusReport StatusReport)
    6 -> Just (CSI_DeviceStatusReport ReportCursorPosition)
    _ -> Nothing
  'r' ->
    let (top, bottom) = case args of
          t :| [] -> (t, 0)
          t :| (b : _) -> (t, b)
     in Just
          ( CSI_DECSTBM
              (if top == 0 then Nothing else Just top)
              (if bottom == 0 then Nothing else Just bottom)
          )
  'm' -> Just $ CSI_SGR (V.fromList (mapMaybe codeToSGR (NE.toList args)))
  _ -> Nothing

parsePrivCsi :: Char -> NonEmpty Int -> Maybe ControlSequenceIntroducer
parsePrivCsi mode args = case mode of
  'h' ->
    let n = (headChangeZero 1 args)
     in Just $ case intToDECPrivateMode n of
          Just decset -> CSI_DECSET decset
          Nothing -> CSI_DECSET_Unknown n
  'l' ->
    let n = (headChangeZero 1 args)
     in Just $ case intToDECPrivateMode n of
          Just decset -> CSI_DECRST decset
          Nothing -> CSI_DECRST_Unknown n
  _ -> Nothing

processControlSequenceIntroducer :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducer
processControlSequenceIntroducer csiInput =
  parseControlSequenceIntroducerComponents csiInput
    >>= processControlSequenceIntroducerComponents

processOtherControlSequenceIntroducer :: ControlSequenceIntroducerInput -> Maybe ControlSequenceIntroducer
processOtherControlSequenceIntroducer (ControlSequenceIntroducerInput str) =
  case str of
    "!p" -> Just CSI_SoftTerminalReset
    ">c" -> Just (CSI_SendDeviceAttributesSecondary RequestTerminalIdentificationCode)
    ">0c" -> Just (CSI_SendDeviceAttributesSecondary RequestTerminalIdentificationCode)
    _
      | "?" `T.isPrefixOf` str && "$p" `T.isSuffixOf` str ->
        let modeStr = T.init (T.init (T.tail str))
         in case T.decimal modeStr of
              Left _ -> Nothing
              Right (mode, "") -> Just (CSI_RequestDECPrivateMode mode)
              Right (_, _) -> Nothing
    _ -> Nothing

-- | Used for error reporting
renderCsi :: ControlSequenceIntroducerInput -> Text
renderCsi (ControlSequenceIntroducerInput str) = "\ESC[" <> str

-----------------------------------------------------------------------
-- OSC (Operating System Command)
-----------------------------------------------------------------------

data OperatingSystemCommandInput = OperatingSystemCommandInput !Text

-- | Should be run after reading the sequence @ESC ]@
--
-- This parser always succeeds
parseOperatingSystemCommand :: Parser OperatingSystemCommandInput
parseOperatingSystemCommand = do
  str <-
    manyTill'
      anyChar
      ( (char '\a' >> pure ())
          <|> (string "\ESC\\" >> pure ())
      )
  pure (OperatingSystemCommandInput (T.pack str))

-- | Used for error reporting
renderOsc :: OperatingSystemCommandInput -> Text
renderOsc (OperatingSystemCommandInput str) = "\ESC]" <> str <> "\a"

processOperatingSystemCommand :: OperatingSystemCommandInput -> Maybe OperatingSystemCommand
processOperatingSystemCommand (OperatingSystemCommandInput str) =
  case parseOnly (parser <* endOfInput) str of
    Left _ -> Nothing
    Right val -> Just val
  where
    parser :: Parser OperatingSystemCommand
    parser =
      parseSetTitle
        <|> parseChangeTextForegroundColor
        <|> parseRequestTextForegroundColor
        <|> parseChangeTextBackgroundColor
        <|> parseRequestTextBackgroundColor
        <|> parseResetTextCursorColor

    parseSetTitle :: Parser OperatingSystemCommand
    parseSetTitle = do
      (icon, window) <- parseSetTitleMode
      _ <- char ';'
      title <- takeText
      pure (OSC_SetTitle icon window title)

    parseSetTitleMode :: Parser (Bool, Bool)
    parseSetTitleMode =
      (char '0' >> pure (True, True))
        <|> (char '1' >> pure (True, False))
        <|> (char '2' >> pure (False, True))

    parseChangeTextForegroundColor :: Parser OperatingSystemCommand
    parseChangeTextForegroundColor = do
      _ <- string "10;"
      c <- satisfy (/= '?')
      color <- takeText
      pure (OSC_ChangeTextForegroundColor (T.singleton c <> color))

    parseRequestTextForegroundColor :: Parser OperatingSystemCommand
    parseRequestTextForegroundColor = do
      _ <- string "10;?"
      pure OSC_RequestTextForegroundColor

    parseChangeTextBackgroundColor :: Parser OperatingSystemCommand
    parseChangeTextBackgroundColor = do
      _ <- string "11;"
      c <- satisfy (/= '?')
      color <- takeText
      pure (OSC_ChangeTextBackgroundColor (T.singleton c <> color))

    parseRequestTextBackgroundColor :: Parser OperatingSystemCommand
    parseRequestTextBackgroundColor = do
      _ <- string "11;?"
      pure OSC_RequestTextBackgroundColor

    parseResetTextCursorColor :: Parser OperatingSystemCommand
    parseResetTextCursorColor = do
      _ <- string "112"
      pure OSC_ResetTextCursorColor

-----------------------------------------------------------------------
-- Single Character Escape Sequence
-----------------------------------------------------------------------

singleCharacterEscapeSequence :: Char -> Maybe EscapeSequence
singleCharacterEscapeSequence c =
  case c of
    'M' -> Just Esc_ReverseIndex
    'c' -> Just Esc_RIS
    '=' -> Just Esc_DECPAM
    '>' -> Just Esc_DECPNM
    _ -> Nothing

-----------------------------------------------------------------------
-- Helper functions
-----------------------------------------------------------------------

between :: Ord a => a -> (a, a) -> Bool
between val (low, high) = val >= low && val <= high

isControlC0 :: Char -> Bool
isControlC0 c = fromEnum c `between` (0, 0x1F) || c == '\DEL'

isControlC1 :: Char -> Bool
isControlC1 c = fromEnum c `between` (0x80, 0x9f)

isControl :: Char -> Bool
isControl c = isControlC0 c || isControlC1 c