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.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 (Formatted attr -> Formatted attr -> Bool
(Formatted attr -> Formatted attr -> Bool)
-> (Formatted attr -> Formatted attr -> Bool)
-> Eq (Formatted attr)
forall attr. Eq attr => Formatted attr -> Formatted attr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Formatted attr -> Formatted attr -> Bool
$c/= :: forall attr. Eq attr => Formatted attr -> Formatted attr -> Bool
== :: Formatted attr -> Formatted attr -> Bool
$c== :: forall attr. Eq attr => Formatted attr -> Formatted attr -> Bool
Eq, Int -> Formatted attr -> ShowS
[Formatted attr] -> ShowS
Formatted attr -> String
(Int -> Formatted attr -> ShowS)
-> (Formatted attr -> String)
-> ([Formatted attr] -> ShowS)
-> Show (Formatted attr)
forall attr. Show attr => Int -> Formatted attr -> ShowS
forall attr. Show attr => [Formatted attr] -> ShowS
forall attr. Show attr => Formatted attr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Formatted attr] -> ShowS
$cshowList :: forall attr. Show attr => [Formatted attr] -> ShowS
show :: Formatted attr -> String
$cshow :: forall attr. Show attr => Formatted attr -> String
showsPrec :: Int -> Formatted attr -> ShowS
$cshowsPrec :: forall attr. Show attr => Int -> Formatted attr -> ShowS
Show)

instance Functor Formatted where
    fmap :: (a -> b) -> Formatted a -> Formatted b
fmap a -> b
f = \case
        Formatted a
Empty        -> Formatted b
forall attr. Formatted attr
Empty
        Text Int
l Text
t     -> Int -> Text -> Formatted b
forall attr. Int -> Text -> Formatted attr
Text Int
l Text
t
        Format Int
l a
a Formatted a
t -> Int -> b -> Formatted b -> Formatted b
forall attr. Int -> attr -> Formatted attr -> Formatted attr
Format Int
l (a -> b
f a
a) ((a -> b) -> Formatted a -> Formatted b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Formatted a
t)
        Cat Int
l [Formatted a]
ts     -> Int -> [Formatted b] -> Formatted b
forall attr. Int -> [Formatted attr] -> Formatted attr
Cat Int
l ((Formatted a -> Formatted b) -> [Formatted a] -> [Formatted b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Formatted a -> Formatted b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Formatted a]
ts)

instance (Eq attr, Semigroup attr) => Semigroup (Formatted attr) where
    <> :: Formatted attr -> Formatted attr -> Formatted attr
(<>) = Formatted attr -> Formatted attr -> Formatted attr
forall attr.
(Eq attr, Semigroup attr) =>
Formatted attr -> Formatted attr -> Formatted attr
fuse

instance (Eq attr, Semigroup attr) => Monoid (Formatted attr) where
    mempty :: Formatted attr
mempty = Formatted attr
forall attr. Formatted attr
Empty


-- | 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 :: Formatted attr
emptyFormatted = Formatted attr
forall attr. Formatted attr
Empty

-- | Smart constructor for bare (unformatted) text.
--
-- >>> bare ""
-- Empty
--
-- >>> bare "Text"
-- Text 4 "Text"
--
bare :: Text -> Formatted attr
bare :: Text -> Formatted attr
bare Text
t
    | Text -> Bool
T.null Text
t  = Formatted attr
forall attr. Formatted attr
emptyFormatted
    | Bool
otherwise = Int -> Text -> Formatted attr
forall attr. Int -> Text -> Formatted attr
Text (Text -> Int
T.length Text
t) Text
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 -> Formatted attr
format attr
attr Formatted attr
formatted
    | attr
attr attr -> attr -> Bool
forall a. Eq a => a -> a -> Bool
== attr
forall a. Monoid a => a
mempty = Formatted attr
formatted
    | Format Int
l attr
attr' Formatted attr
formatted' <- Formatted attr
formatted
                     = Int -> attr -> Formatted attr -> Formatted attr
forall attr. Int -> attr -> Formatted attr -> Formatted attr
Format Int
l (attr
attr attr -> attr -> attr
forall a. Semigroup a => a -> a -> a
<> attr
attr') Formatted attr
formatted'
    | Bool
otherwise      = attr -> Formatted attr -> Formatted attr
forall attr. attr -> Formatted attr -> Formatted attr
format' attr
attr Formatted attr
formatted

format' :: attr -> Formatted attr -> Formatted attr
format' :: attr -> Formatted attr -> Formatted attr
format' attr
attr Formatted attr
formatted = Int -> attr -> Formatted attr -> Formatted attr
forall attr. Int -> attr -> Formatted attr -> Formatted attr
Format (Formatted attr -> Int
forall attr. Formatted attr -> Int
length Formatted attr
formatted) attr
attr 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 :: [Formatted attr] -> Formatted attr
cat = \case
    []  -> Formatted attr
forall attr. Formatted attr
emptyFormatted
    [Formatted attr
t] -> Formatted attr
t
    [Formatted attr]
ts  -> (Formatted attr -> Formatted attr -> Formatted attr)
-> Formatted attr -> [Formatted attr] -> Formatted attr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Formatted attr -> Formatted attr -> Formatted attr
forall attr.
(Eq attr, Semigroup attr) =>
Formatted attr -> Formatted attr -> Formatted attr
fuse Formatted attr
forall attr. Formatted attr
emptyFormatted [Formatted attr]
ts

cat' :: [Formatted attr] -> Formatted attr
cat' :: [Formatted attr] -> Formatted attr
cat' = \case
    []  -> Formatted attr
forall attr. Formatted attr
emptyFormatted
    [Formatted attr
t] -> Formatted attr
t
    [Formatted attr]
ts  -> Int -> [Formatted attr] -> Formatted attr
forall attr. Int -> [Formatted attr] -> Formatted attr
Cat ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Formatted attr -> Int) -> [Formatted attr] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Formatted attr -> Int
forall attr. Formatted attr -> Int
length [Formatted attr]
ts)) [Formatted attr]
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, Semigroup attr) => Formatted attr -> Formatted attr -> Formatted attr
fuse :: Formatted attr -> Formatted attr -> Formatted attr
fuse Formatted attr
left Formatted attr
right = case (Formatted attr
left, Formatted attr
right) of
    (Formatted attr
Empty,           Formatted attr
formatted)    -> Formatted attr
formatted
    (Formatted attr
formatted,       Formatted attr
Empty)        -> Formatted attr
formatted
    (Text Int
l Text
t,        Text Int
l' Text
t')   -> Int -> Text -> Formatted attr
forall attr. Int -> Text -> Formatted attr
Text (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l') (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t')
    (Format Int
l attr
attr Formatted attr
t, Format Int
l' attr
attr' Formatted attr
t')
        | attr
attr' attr -> attr -> Bool
forall a. Eq a => a -> a -> Bool
== attr
attr             -> Int -> attr -> Formatted attr -> Formatted attr
forall attr. Int -> attr -> Formatted attr -> Formatted attr
Format (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l') attr
attr (Formatted attr
t Formatted attr -> Formatted attr -> Formatted attr
forall a. Semigroup a => a -> a -> a
<> Formatted attr
t')

    (Cat Int
l [Formatted attr]
ts,        Cat Int
l' [Formatted attr]
ts')   -> Int -> [Formatted attr] -> Formatted attr
forall attr. Int -> [Formatted attr] -> Formatted attr
Cat (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l') ([Formatted attr]
ts [Formatted attr] -> [Formatted attr] -> [Formatted attr]
forall a. [a] -> [a] -> [a]
++ [Formatted attr]
ts')
    (Cat Int
l [Formatted attr]
ts,        Formatted attr
formatted)    -> Int -> [Formatted attr] -> Formatted attr
forall attr. Int -> [Formatted attr] -> Formatted attr
Cat (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Formatted attr -> Int
forall attr. Formatted attr -> Int
length Formatted attr
formatted) ([Formatted attr]
ts [Formatted attr] -> [Formatted attr] -> [Formatted attr]
forall a. [a] -> [a] -> [a]
++ [Formatted attr
formatted])
    (Formatted attr
formatted,       Cat Int
_ (Formatted attr
t:[Formatted attr]
ts)) -> case Formatted attr
formatted Formatted attr -> Formatted attr -> Formatted attr
forall attr.
(Eq attr, Semigroup attr) =>
Formatted attr -> Formatted attr -> Formatted attr
`fuse` Formatted attr
t of
                                          Cat Int
_ [Formatted attr]
ts' -> [Formatted attr] -> Formatted attr
forall attr. [Formatted attr] -> Formatted attr
cat' ([Formatted attr]
ts' [Formatted attr] -> [Formatted attr] -> [Formatted attr]
forall a. [a] -> [a] -> [a]
++ [Formatted attr]
ts)
                                          Formatted attr
t'        -> [Formatted attr] -> Formatted attr
forall attr. [Formatted attr] -> Formatted attr
cat' (Formatted attr
t' Formatted attr -> [Formatted attr] -> [Formatted attr]
forall a. a -> [a] -> [a]
: [Formatted attr]
ts)
    (Formatted attr
formatted,     Formatted attr
formatted')     -> [Formatted attr] -> Formatted attr
forall attr. [Formatted attr] -> Formatted attr
cat' [Formatted attr
formatted, Formatted attr
formatted']

length :: Formatted attr -> Int
length :: Formatted attr -> Int
length = \case
    Formatted attr
Empty        -> Int
0
    Text   Int
l Text
_   -> Int
l
    Format Int
l attr
_ Formatted attr
_ -> Int
l
    Cat    Int
l [Formatted attr]
_   -> Int
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 :: (Text -> Text) -> Formatted a -> Formatted a
mapText Text -> Text
f = \case
    Formatted a
Empty           -> Formatted a
forall attr. Formatted attr
emptyFormatted
    Text Int
_ Text
t        -> Text -> Formatted a
forall attr. Text -> Formatted attr
bare (Text -> Text
f Text
t)
    Format Int
_ a
attr Formatted a
t -> a -> Formatted a -> Formatted a
forall attr. attr -> Formatted attr -> Formatted attr
format' a
attr ((Text -> Text) -> Formatted a -> Formatted a
forall a. (Text -> Text) -> Formatted a -> Formatted a
mapText Text -> Text
f Formatted a
t)
    Cat Int
_ [Formatted a]
ts        -> [Formatted a] -> Formatted a
forall attr. [Formatted attr] -> Formatted attr
cat' ((Formatted a -> Formatted a) -> [Formatted a] -> [Formatted a]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> Formatted a -> Formatted a
forall a. (Text -> Text) -> Formatted a -> Formatted a
mapText Text -> Text
f) [Formatted a]
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 :: (Int -> Text -> Text) -> Formatted a -> Formatted a
mapTextWithPos Int -> Text -> Text
f = Int -> Formatted a -> Formatted a
forall attr. Int -> Formatted attr -> Formatted attr
go Int
0
  where
    go :: Int -> Formatted attr -> Formatted attr
go Int
pos = \case
        Formatted attr
Empty           -> Formatted attr
forall attr. Formatted attr
emptyFormatted
        Text Int
_ Text
t        -> Text -> Formatted attr
forall attr. Text -> Formatted attr
bare (Int -> Text -> Text
f Int
pos Text
t)
        Format Int
_ attr
attr Formatted attr
t -> attr -> Formatted attr -> Formatted attr
forall attr. attr -> Formatted attr -> Formatted attr
format' attr
attr (Int -> Formatted attr -> Formatted attr
go Int
pos Formatted attr
t)
        Cat Int
_ [Formatted attr]
ts        -> [Formatted attr] -> Formatted attr
forall attr. [Formatted attr] -> Formatted attr
cat' (Int -> [Formatted attr] -> [Formatted attr]
go2 Int
pos [Formatted attr]
ts)
    go2 :: Int -> [Formatted attr] -> [Formatted attr]
go2 Int
pos = \case
        []     -> []
        Formatted attr
t : [Formatted attr]
ts -> let t' :: Formatted attr
t'  = Int -> Formatted attr -> Formatted attr
go Int
pos Formatted attr
t
                      l' :: Int
l'  = Formatted attr -> Int
forall attr. Formatted attr -> Int
length Formatted attr
t'
                      ts' :: [Formatted attr]
ts' = Int -> [Formatted attr] -> [Formatted attr]
go2 (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l') [Formatted attr]
ts
                  in  Formatted attr
t' Formatted attr -> [Formatted attr] -> [Formatted attr]
forall a. a -> [a] -> [a]
: [Formatted attr]
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 :: Int -> Formatted a -> Formatted a
takeFormatted Int
w Formatted a
txt
    | Formatted a -> Int
forall attr. Formatted attr -> Int
length Formatted a
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
w  = (Int -> Text -> Text) -> Formatted a -> Formatted a
forall a. (Int -> Text -> Text) -> Formatted a -> Formatted a
mapTextWithPos Int -> Text -> Text
cropChunk Formatted a
txt
    | Bool
otherwise       = Formatted a
txt
  where
    cropChunk :: Int -> Text -> Text
cropChunk Int
pos
        | Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
w   = Text -> Text -> Text
forall a b. a -> b -> a
const Text
T.empty
        | Bool
otherwise  = Int -> Text -> Text
T.take (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 :: Int -> Formatted a -> Formatted a
dropFormatted Int
amount Formatted a
txt
    | Int
amount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0          = Formatted a
txt
    | Formatted a -> Int
forall attr. Formatted attr -> Int
length Formatted a
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
amount  = Formatted a
forall attr. Formatted attr
emptyFormatted
    | Bool
otherwise = case Formatted a
txt of
        Formatted a
Empty           -> Formatted a
forall attr. Formatted attr
emptyFormatted
        Text Int
_ Text
t        -> Text -> Formatted a
forall attr. Text -> Formatted attr
bare (Int -> Text -> Text
T.drop Int
amount Text
t)
        Format Int
_ a
attr Formatted a
t -> a -> Formatted a -> Formatted a
forall attr. attr -> Formatted attr -> Formatted attr
format' a
attr (Int -> Formatted a -> Formatted a
forall attr. Int -> Formatted attr -> Formatted attr
dropFormatted Int
amount Formatted a
t)
        Cat Int
_ [Formatted a]
ts        -> [Formatted a] -> Formatted a
forall attr. [Formatted attr] -> Formatted attr
cat' (Int -> [Formatted a] -> [Formatted a]
forall attr. Int -> [Formatted attr] -> [Formatted attr]
dropChunks Int
amount [Formatted a]
ts)
  where
    dropChunks :: Int -> [Formatted attr] -> [Formatted attr]
dropChunks Int
n = \case
        []   -> []
        Formatted attr
t:[Formatted attr]
ts -> Int -> Formatted attr -> Formatted attr
forall attr. Int -> Formatted attr -> Formatted attr
dropFormatted Int
n Formatted attr
t Formatted attr -> [Formatted attr] -> [Formatted attr]
forall a. a -> [a] -> [a]
: Int -> [Formatted attr] -> [Formatted attr]
dropChunks (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Formatted attr -> Int
forall attr. Formatted attr -> Int
length Formatted attr
t) [Formatted attr]
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 :: Int -> Char -> Formatted a -> Formatted a
padFormatted Int
w Char
c Formatted a
txt
    | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Formatted a -> Int
forall attr. Formatted attr -> Int
length Formatted a
txt  = [Formatted a] -> Formatted a
forall attr. [Formatted attr] -> Formatted attr
cat' [Formatted a
txt, Int -> Formatted a
forall attr. Int -> Formatted attr
padding (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Formatted a -> Int
forall attr. Formatted attr -> Int
length Formatted a
txt)]
    | Bool
otherwise       = Formatted a
txt
  where
    padding :: Int -> Formatted attr
padding Int
l = Text -> Formatted attr
forall attr. Text -> Formatted attr
bare (Int -> Text -> Text
T.replicate Int
l (Char -> Text
T.singleton Char
c))