{-# LANGUAGE OverloadedStrings #-}

module Codec.Sarsi.Curses where

import Data.Attoparsec.Text
import qualified Data.Attoparsec.Text as AttoText
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text

-- note: expect a line that does NOT ends with a LF
cleanLine :: Text -> Text
cleanLine :: Text -> Text
cleanLine Text
txt | Text -> Bool
Text.null Text
txt = Text
txt
cleanLine Text
txt | Text -> Char
Text.last Text
txt Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
Text.empty (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text
f (Text -> Text) -> ((Text, Char) -> Text) -> (Text, Char) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Char) -> Text
forall a b. (a, b) -> a
fst) ((Text, Char) -> Text) -> Maybe (Text, Char) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Text, Char)
Text.unsnoc Text
txt
  where
    f :: Text -> Text
f Text
x = case Text -> Text -> [(Text, Text)]
Text.breakOnAll Text
"\r" Text
x of
      [] -> Text
x
      [(Text, Text)]
xs -> Text -> Text
Text.tail (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text)
-> ([(Text, Text)] -> (Text, Text)) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> (Text, Text)
forall a. [a] -> a
last) [(Text, Text)]
xs
cleanLine Text
txt = Text
txt

-- Note: this parser remove CSI codes and do a best effort
-- at removing "clear line" instructions while keeping
-- all information exposed without any mangling.
cleaningCurses :: Parser Text
cleaningCurses :: Parser Text
cleaningCurses = [Parser Text] -> Parser Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text
multiples, Parser Text
single, Parser Text
none]
  where
    multiples :: Parser Text
multiples = do
      Text
before <- Parser Text
ln
      Text
middle <- [Parser Text] -> Parser Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text
silenceClearLines, Parser Text
silenceCSI]
      Text
after <- [Parser Text] -> Parser Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text
multiples, Parser Text
single]
      Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
before, Text
"\n", Text
middle, Text
after]
      where
        ln :: Parser Text
ln = do
          Text
before <- (Char -> Bool) -> Parser Text
AttoText.takeWhile (Int -> Bool
forall a. (Eq a, Num a) => a -> Bool
breakAt (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
          Text
after <- [Parser Text] -> Parser Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text
lineFinish, Parser Text
lineContinue]
          Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> Text
Text.concat [Text
before, Text
after])
          where
            breakAt :: a -> Bool
breakAt a
10 = Bool
False -- LF
            breakAt a
27 = Bool
False -- ESC
            breakAt a
_ = Bool
True
        lineFinish :: Parser Text
lineFinish = Char -> Parser Char
char Char
'\n' Parser Char -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"\n")
        lineContinue :: Parser Text
lineContinue = Parser Text
csi Parser Text -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
ln
        silenceClearLines :: Parser Text
silenceClearLines = do
          Text
_ <- (Char -> Bool) -> Parser Text
AttoText.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool
isEsc (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
          [()]
_ <- [Parser Text [()]] -> Parser Text [()]
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text () -> Parser Text [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 (Parser Text ()
cl Parser Text () -> Parser Text -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text
"\n"), Parser Text () -> Parser Text [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 Parser Text ()
cl]
          Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
Text.empty
    single :: Parser Text
single = do
      [Text]
befores <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Parser Text -> Parser Text [Text])
-> Parser Text -> Parser Text [Text]
forall a b. (a -> b) -> a -> b
$ [Parser Text] -> Parser Text
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser Text
clearLine, Parser Text
silenceCSI]
      String
str <- Parser Char -> Parser Text String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 Parser Char
anyChar
      ()
_ <- Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput
      Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> Text
Text.concat [[Text] -> Text
Text.concat [Text]
befores, String -> Text
Text.pack String
str])
      where
        clearLine :: Parser Text
clearLine = do
          Text
_ <- (Char -> Bool) -> Parser Text
AttoText.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool
isEsc (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
          [()]
_ <- Parser Text () -> Parser Text [()]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 Parser Text ()
cl
          Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
Text.empty
    none :: Parser Text
none = do
      Text
ln <- ((Char -> Bool) -> Parser Text
AttoText.takeWhile ((Char -> Bool) -> Parser Text) -> (Char -> Bool) -> Parser Text
forall a b. (a -> b) -> a -> b
$ \Char
w -> Char
w Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
      Text
_ <- Parser Text
"\n"
      Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
ln, Text
"\n"]
    cl :: Parser Text ()
cl = Parser Text ()
csiHeader Parser Text () -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text
string Text
"2K" Parser Text -> Parser Text () -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser Text ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    silenceCSI :: Parser Text
silenceCSI = do
      Text
txt <- (Char -> Bool) -> Parser Text
AttoText.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool
isEsc (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
      [Text]
_ <- Parser Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
AttoText.many1 Parser Text
csi
      Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
txt

-- CSI (Control Sequence Introducer) sequences
csi :: Parser Text
csi :: Parser Text
csi = do
  ()
_ <- Parser Text ()
csiHeader
  Text
param <- Int -> Int -> Parser Text
takeWhileInRange Int
0x30 Int
0x3F
  Text
inter <- Int -> Int -> Parser Text
takeWhileInRange Int
0x20 Int
0x2F
  Char
final <- (Char -> Bool) -> Parser Char
satisfy ((Int -> Int -> Int -> Bool
forall a. Ord a => a -> a -> a -> Bool
inRange Int
0x40 Int
0x7E) (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
  Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.concat [Text
param, Text
inter, Char -> Text
Text.singleton Char
final]
  where
    takeWhileInRange :: Int -> Int -> Parser Text
takeWhileInRange Int
l Int
u = (Char -> Bool) -> Parser Text
AttoText.takeWhile (Int -> Int -> Int -> Bool
forall a. Ord a => a -> a -> a -> Bool
inRange Int
l Int
u (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum)
    inRange :: a -> a -> a -> Bool
inRange a
l a
u a
i | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
l Bool -> Bool -> Bool
&& a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
u = Bool
True
    inRange a
_ a
_ a
_ = Bool
False

csiHeader :: Parser ()
csiHeader :: Parser Text ()
csiHeader = ((Char -> Bool) -> Parser Char
satisfy (Int -> Bool
isEsc (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
char Char
'[') Parser Char -> Parser Text () -> Parser Text ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser Text ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

isEsc :: Int -> Bool
isEsc :: Int -> Bool
isEsc Int
27 = Bool
True
isEsc Int
_ = Bool
False