module Vgrep.Ansi.Type ( Formatted (..) , AnsiFormatted -- * Smart constructors , emptyFormatted , bare , format , cat -- * Modifying the underlying text , mapText , mapTextWithPos , takeFormatted , dropFormatted , padFormatted -- * Internal helpers , 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) -- | A representattion of formatted 'Text'. The attribute is usually a 'Monoid' -- so that different formattings can be combined by nesting them. data Formatted attr = Empty -- ^ An empty block | Text !Int Text -- ^ A bare (unformatted) text node | Format !Int attr (Formatted attr) -- ^ Adds formatting to a block | Cat !Int [Formatted attr] -- ^ Concatenates several blocks of formatted text 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 alias for Text formatted with 'Attr' from "Graphics.Vty". type AnsiFormatted = Formatted Attr -- | Smart constructor for an empty 'Formatted' text. emptyFormatted :: Formatted attr emptyFormatted = Empty -- | Smart constructor for bare (unformatted) text. -- -- >>> bare "" -- Empty -- -- >>> bare "Text" -- Text 4 "Text" -- bare :: Text -> Formatted attr bare t | T.null t = emptyFormatted | otherwise = Text (T.length t) t -- | Adds formatting to a 'Formatted' text. The 'Eq' and 'Monoid' instances for -- @attr@ are used to flatten redundant formattings. -- -- >>> format (Just ()) (format Nothing (bare "Text")) -- Format 4 (Just ()) (Text 4 "Text") -- -- >>> format (Just ()) (format (Just ()) (bare "Text")) -- Format 4 (Just ()) (Text 4 "Text") -- -- >>> format Nothing (bare "Text") -- Text 4 "Text" -- 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 -- | Concatenates pieces of 'Formatted' text. Redundant formattings and blocks -- of equal formatting are 'fuse'd together. 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 -- | Simplifies 'Formatted' text by leaving out redundant empty bits, joining -- pieces of text with the same formatting, and flattening redundant -- applications of the same style. -- -- >>> emptyFormatted `fuse` bare "Text" -- Text 4 "Text" -- -- >>> format (Just ()) (bare "Left") `fuse` format (Just ()) (bare "Right") -- Format 9 (Just ()) (Text 9 "LeftRight") -- 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 -- | Apply a function to each piece of text in the 'Formatted' tree. -- -- >>> mapText T.toUpper (Cat 11 [Text 6 "Hello ", Format 5 () (Text 5 "World")]) -- Cat 11 [Text 6 "HELLO ",Format 5 () (Text 5 "WORLD")] -- 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) -- | Like 'mapText', but passes the position of the text chunk to the function -- as well. Can be used for formatting text position-dependently, e.g. for -- expanding tabs to spaces. 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' -- | Crops the text to a given length. If the text is already shorter than the -- desired width, it is returned as-is. 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) -- | Drops a prefix of the given length. If the text is already shorter than the -- number of characters to be dropped, 'emptyFormatted' is returned. 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 -- | Pads the text to a given width. If the text is already longer than the -- desired width, it is returned as-is. 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))