module Vgrep.Ansi.Type
( Formatted (..)
, AnsiFormatted
, emptyFormatted
, bare
, format
, cat
, mapText
, mapTextWithPos
, takeFormatted
, dropFormatted
, padFormatted
, fuse
) where
import Data.Foldable (foldl')
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Graphics.Vty (Attr)
import Prelude hiding (length)
data Formatted attr
= Empty
| Text !Int Text
| Format !Int attr (Formatted attr)
| Cat !Int [Formatted attr]
deriving (Eq, Show)
instance Functor Formatted where
fmap f = \case
Empty -> Empty
Text l t -> Text l t
Format l a t -> Format l (f a) (fmap f t)
Cat l ts -> Cat l (map (fmap f) ts)
instance (Eq attr, Monoid attr) => Monoid (Formatted attr) where
mempty = Empty
mappend = fuse
type AnsiFormatted = Formatted Attr
emptyFormatted :: Formatted attr
emptyFormatted = Empty
bare :: Text -> Formatted attr
bare t
| T.null t = emptyFormatted
| otherwise = Text (T.length t) t
format :: (Eq attr, Monoid attr) => attr -> Formatted attr -> Formatted attr
format attr formatted
| attr == mempty = formatted
| Format l attr' formatted' <- formatted
= Format l (attr <> attr') formatted'
| otherwise = format' attr formatted
format' :: attr -> Formatted attr -> Formatted attr
format' attr formatted = Format (length formatted) attr formatted
cat :: (Eq attr, Monoid attr) => [Formatted attr] -> Formatted attr
cat = \case
[] -> emptyFormatted
[t] -> t
ts -> foldl' fuse emptyFormatted ts
cat' :: [Formatted attr] -> Formatted attr
cat' = \case
[] -> emptyFormatted
[t] -> t
ts -> Cat (sum (fmap length ts)) ts
fuse :: (Eq attr, Monoid attr) => Formatted attr -> Formatted attr -> Formatted attr
fuse left right = case (left, right) of
(Empty, formatted) -> formatted
(formatted, Empty) -> formatted
(Text l t, Text l' t') -> Text (l + l') (t <> t')
(Format l attr t, Format l' attr' t')
| attr' == attr -> Format (l + l') attr (t <> t')
(Cat l ts, Cat l' ts') -> Cat (l + l') (ts ++ ts')
(Cat l ts, formatted) -> Cat (l + length formatted) (ts ++ [formatted])
(formatted, Cat _ (t:ts)) -> case formatted `fuse` t of
Cat _ ts' -> cat' (ts' ++ ts)
t' -> cat' (t' : ts)
(formatted, formatted') -> cat' [formatted, formatted']
length :: Formatted attr -> Int
length = \case
Empty -> 0
Text l _ -> l
Format l _ _ -> l
Cat l _ -> l
mapText :: (Text -> Text) -> Formatted a -> Formatted a
mapText f = \case
Empty -> emptyFormatted
Text _ t -> bare (f t)
Format _ attr t -> format' attr (mapText f t)
Cat _ ts -> cat' (map (mapText f) ts)
mapTextWithPos :: (Int -> Text -> Text) -> Formatted a -> Formatted a
mapTextWithPos f = go 0
where
go pos = \case
Empty -> emptyFormatted
Text _ t -> bare (f pos t)
Format _ attr t -> format' attr (go pos t)
Cat _ ts -> cat' (go2 pos ts)
go2 pos = \case
[] -> []
t : ts -> let t' = go pos t
l' = length t'
ts' = go2 (pos + l') ts
in t' : ts'
takeFormatted :: Int -> Formatted a -> Formatted a
takeFormatted w txt
| length txt > w = mapTextWithPos cropChunk txt
| otherwise = txt
where
cropChunk pos
| pos >= w = const T.empty
| otherwise = T.take (w pos)
dropFormatted :: Int -> Formatted a -> Formatted a
dropFormatted amount txt
| amount <= 0 = txt
| length txt < amount = emptyFormatted
| otherwise = case txt of
Empty -> emptyFormatted
Text _ t -> bare (T.drop amount t)
Format _ attr t -> format' attr (dropFormatted amount t)
Cat _ ts -> cat' (dropChunks amount ts)
where
dropChunks n = \case
[] -> []
t:ts -> dropFormatted n t : dropChunks (n length t) ts
padFormatted :: Int -> Char -> Formatted a -> Formatted a
padFormatted w c txt
| w > length txt = cat' [txt, padding (w length txt)]
| otherwise = txt
where
padding l = bare (T.replicate l (T.singleton c))