{-# 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
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
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
breakAt a
27 = Bool
False
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 :: 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 ()
= ((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