content: {-# LANGUAGE OverloadedStrings #-}
  module Vgrep.Ansi.Parser
    ( parseAnsi
    , ansiFormatted
    , attrChange
    ) where
  
  
  import           Control.Applicative
  import           Data.Attoparsec.Text
  import           Data.Bits
  import           Data.Functor
  import           Data.Text               (Text)
  import qualified Data.Text               as T
  import           Graphics.Vty.Attributes (Attr)
  import qualified Graphics.Vty.Attributes as Vty
  
  import Vgrep.Ansi.Type
  
  
  {- |
  Directly parses ANSI formatted text using 'ansiFormatted'.
  
  Parsing ANSI color codes:
  
  >>> parseAnsi "Hello \ESC[31mWorld\ESC[m!"
  Cat 12 [Text 6 "Hello ",Format 5 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 5 "World"),Text 1 "!"]
  
  More elaborate example with nested foreground and background colors:
  
  >>> parseAnsi "\ESC[m\ESC[40mHello \ESC[31mWorld\ESC[39m!"
  Cat 12 [Format 6 (Attr {attrStyle = KeepCurrent, attrForeColor = KeepCurrent, attrBackColor = SetTo (ISOColor 0), attrURL = KeepCurrent}) (Text 6 "Hello "),Format 5 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = SetTo (ISOColor 0), attrURL = KeepCurrent}) (Text 5 "World"),Format 1 (Attr {attrStyle = KeepCurrent, attrForeColor = KeepCurrent, attrBackColor = SetTo (ISOColor 0), attrURL = KeepCurrent}) (Text 1 "!")]
  
  Some CSI sequences are ignored, since they are not supported by 'Vty':
  
  >>> parseAnsi "\ESC[A\ESC[B\ESC[31mfoo\ESC[1K\ESC[mbar"
  Cat 6 [Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 3 "foo"),Text 3 "bar"]
  
  Non-CSI sequences are not parsed, but included in the output:
  
  >>> parseAnsi "\ESC]710;font\007foo\ESC[31mbar"
  Cat 17 [Text 14 "\ESC]710;font\afoo",Format 3 (Attr {attrStyle = KeepCurrent, attrForeColor = SetTo (ISOColor 1), attrBackColor = KeepCurrent, attrURL = KeepCurrent}) (Text 3 "bar")]
  
  -}
  parseAnsi :: Text -> AnsiFormatted
  parseAnsi = either error id . parseOnly ansiFormatted
  -- The use of 'error' ↑ is safe: 'ansiFormatted' does not fail.
  
  
  -- | Parser for ANSI formatted text. Recognized escape sequences are the SGR
  -- (Select Graphic Rendition) sequences (@\ESC[…m@) supported by 'Attr'.
  -- Unsupported SGR sequences and other CSI escape sequences (@\ESC[…@) are
  -- ignored. Other (non-CSI) escape sequences are not parsed, and included in the
  -- output.
  --
  -- This parser does not fail, it will rather consume and return the remaining
  -- input as unformatted text.
  ansiFormatted :: Parser AnsiFormatted
  ansiFormatted = go mempty
    where
      go :: Attr -> Parser AnsiFormatted
      go attr = endOfInput $> mempty
            <|> formattedText attr
  
      formattedText :: Attr -> Parser AnsiFormatted
      formattedText attr = do
          acs <- many attrChange
          let attr' = foldr ($) attr (reverse acs)
          t <- rawText
          rest <- go attr'
          pure (format attr' (bare t) <> rest)
  
      rawText :: Parser Text
      rawText = atLeastOneTill (== '\ESC') <|> endOfInput $> ""
  
      atLeastOneTill :: (Char -> Bool) -> Parser Text
      atLeastOneTill = liftA2 T.cons anyChar . takeTill
  
  
  -- | Parser for ANSI CSI escape sequences. Recognized escape sequences are the
  -- SGR (Select Graphic Rendition) sequences (@\ESC[…m@) supported by 'Attr'.
  -- Unsupported SGR sequences and other CSI escape sequences (@\ESC[…@) are
  -- ignored by returning 'id'.
  --
  -- This parser fails when encountering any other (non-CSI) escape sequence.
  attrChange :: Parser (Attr -> Attr)
  attrChange = fmap csiToAttrChange csi
  
  csiEscape :: Parser Text
  csiEscape = "\ESC["
  
  csi :: Parser Csi
  csi = csiEscape >> liftA2 Csi (decimal `sepBy` char ';') anyChar
  
  data Csi = Csi [Int] Char
  
  csiToAttrChange :: Csi -> Attr -> Attr
  csiToAttrChange = \case
      Csi [] 'm' -> const mempty
      Csi is 'm' -> foldMap attrChangeFromCode is
      _otherwise -> id
  
  attrChangeFromCode :: Int -> Attr -> Attr
  attrChangeFromCode = \case
      0  -> const mempty
      1  -> withStyle Vty.bold
      3  -> withStyle Vty.standout
      4  -> withStyle Vty.underline
      5  -> withStyle Vty.blink
      6  -> withStyle Vty.blink
      7  -> withStyle Vty.reverseVideo
      21 -> withoutStyle Vty.bold
      22 -> withoutStyle Vty.bold
      23 -> withoutStyle Vty.standout
      24 -> withoutStyle Vty.underline
      25 -> withoutStyle Vty.blink
      27 -> withoutStyle Vty.reverseVideo
      i | i >= 30  && i <= 37   -> withForeColor (rawColor (i - 30))
        | i >= 40  && i <= 47   -> withBackColor (rawColor (i - 40))
        | i >= 90  && i <= 97   -> withForeColor (rawBrightColor (i - 90))
        | i >= 100 && i <= 107  -> withBackColor (rawBrightColor (i - 100))
      39 -> resetForeColor
      49 -> resetBackColor
      _  -> id
    where
      rawColor = \case
          0 -> Vty.black
          1 -> Vty.red
          2 -> Vty.green
          3 -> Vty.yellow
          4 -> Vty.blue
          5 -> Vty.magenta
          6 -> Vty.cyan
          _ -> Vty.white
      rawBrightColor = \case
          0 -> Vty.brightBlack
          1 -> Vty.brightRed
          2 -> Vty.brightGreen
          3 -> Vty.brightYellow
          4 -> Vty.brightBlue
          5 -> Vty.brightMagenta
          6 -> Vty.brightCyan
          _ -> Vty.brightWhite
      withStyle = flip Vty.withStyle
      withForeColor = flip Vty.withForeColor
      withBackColor = flip Vty.withBackColor
      withoutStyle style attr = case Vty.attrStyle attr of
          Vty.SetTo oldStyle | oldStyle `Vty.hasStyle` style
                     -> attr { Vty.attrStyle = Vty.SetTo (oldStyle .&. complement style) }
          _otherwise -> attr
      resetForeColor attr = attr { Vty.attrForeColor = Vty.KeepCurrent }
      resetBackColor attr = attr { Vty.attrBackColor = Vty.KeepCurrent }
  