-- | This module performs line-wrapping of sequences of flattend inline
-- values produced by 'flattenInlineSeq'.
--
-- This process works by maintaining a 'WrapState' in the 'WrapM'
-- monad, where inline values are pushed onto the current line, and
-- line breaks are introduced as inlines exceed the available width.
-- The most important caveat of this module is that wrapping depends
-- on knowing the width of each 'FlattenedValue', which is provided
-- by the 'fvWidth' function. But 'fvWidth' must return values that
-- are consistent with the how the inlines actually get rendered by
-- 'renderFlattenedValue'. This is because there are visual aspects to
-- how some inlines get rendered that are implicit, such as user or
-- channel sigils that get added at drawing time, that have an impact on
-- their visible width.
module Matterhorn.Draw.RichText.Wrap
  ( WrappedLine
  , doLineWrapping
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Brick as B
import           Control.Monad.State
import qualified Data.Sequence as Seq
import           Data.Sequence ( ViewL(..)
                               , (|>)
                               )
import qualified Data.Text as T

import           Matterhorn.Constants ( normalChannelSigil, userSigil )
import           Matterhorn.Draw.RichText.Flatten
import           Matterhorn.Constants ( editMarking )


type WrappedLine a = Seq (FlattenedValue a)

data WrapState a =
    WrapState { WrapState a -> Seq (WrappedLine a)
wrapCompletedLines :: Seq (WrappedLine a)
              -- ^ The completed lines so far
              , WrapState a -> WrappedLine a
wrapCurLine :: (WrappedLine a)
              -- ^ The current line we are accumulating
              , WrapState a -> Int
wrapCurCol :: Int
              -- ^ The width of wrapCurLine, in columns
              , WrapState a -> Int
wrapWidth :: Int
              -- ^ The maximum allowable width
              }

type WrapM a b = State (WrapState b) a

-- | Push a flattened value onto the current line if possible, or add a
-- line break and add the inline value to a new line if it would cause
-- the current line width to exceed the maximum.
pushValue :: FlattenedValue a -> WrapM () a
pushValue :: FlattenedValue a -> WrapM () a
pushValue FlattenedValue a
i = do
    let iw :: Int
iw = FlattenedValue a -> Int
forall a. FlattenedValue a -> Int
fvWidth FlattenedValue a
i
        pushThisInline :: WrapM () a
pushThisInline =
            (WrapState a -> WrapState a) -> WrapM () a
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WrapState a -> WrapState a) -> WrapM () a)
-> (WrapState a -> WrapState a) -> WrapM () a
forall a b. (a -> b) -> a -> b
$ \WrapState a
st -> WrapState a
st { wrapCurLine :: WrappedLine a
wrapCurLine = WrapState a -> WrappedLine a
forall a. WrapState a -> WrappedLine a
wrapCurLine WrapState a
st WrappedLine a -> FlattenedValue a -> WrappedLine a
forall a. Seq a -> a -> Seq a
|> FlattenedValue a
i
                               , wrapCurCol :: Int
wrapCurCol = WrapState a -> Int
forall a. WrapState a -> Int
wrapCurCol WrapState a
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
iw
                               }
    Int
maxWidth <- (WrapState a -> Int) -> StateT (WrapState a) Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WrapState a -> Int
forall a. WrapState a -> Int
wrapWidth
    Int
curWidth <- (WrapState a -> Int) -> StateT (WrapState a) Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WrapState a -> Int
forall a. WrapState a -> Int
wrapCurCol
    let remaining :: Int
remaining = Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curWidth

    Bool -> WrapM () a -> WrapM () a
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
iw Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
remaining) WrapM () a
forall a. WrapM () a
pushLine

    WrapM () a
pushThisInline

-- | Insert a new line break by moving the current accumulating line
-- onto the completed lines list and resetting it to empty.
pushLine :: WrapM () a
pushLine :: WrapM () a
pushLine = do
    let trimLeadingWhitespace :: Seq (FlattenedValue a) -> Seq (FlattenedValue a)
trimLeadingWhitespace Seq (FlattenedValue a)
s =
            case Seq (FlattenedValue a) -> ViewL (FlattenedValue a)
forall a. Seq a -> ViewL a
Seq.viewl Seq (FlattenedValue a)
s of
                SingleInline FlattenedInline a
i :< Seq (FlattenedValue a)
t | FlattenedInline a -> FlattenedContent
forall a. FlattenedInline a -> FlattenedContent
fiValue FlattenedInline a
i FlattenedContent -> FlattenedContent -> Bool
forall a. Eq a => a -> a -> Bool
== FlattenedContent
FSpace -> Seq (FlattenedValue a) -> Seq (FlattenedValue a)
trimLeadingWhitespace Seq (FlattenedValue a)
t
                ViewL (FlattenedValue a)
_ -> Seq (FlattenedValue a)
s

    (WrapState a -> WrapState a) -> WrapM () a
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WrapState a -> WrapState a) -> WrapM () a)
-> (WrapState a -> WrapState a) -> WrapM () a
forall a b. (a -> b) -> a -> b
$ \WrapState a
st ->
        WrapState a
st { wrapCurLine :: WrappedLine a
wrapCurLine = WrappedLine a
forall a. Monoid a => a
mempty
           , wrapCompletedLines :: Seq (WrappedLine a)
wrapCompletedLines = WrapState a -> Seq (WrappedLine a)
forall a. WrapState a -> Seq (WrappedLine a)
wrapCompletedLines WrapState a
st Seq (WrappedLine a) -> WrappedLine a -> Seq (WrappedLine a)
forall a. Seq a -> a -> Seq a
|> WrappedLine a -> WrappedLine a
forall a. Seq (FlattenedValue a) -> Seq (FlattenedValue a)
trimLeadingWhitespace (WrapState a -> WrappedLine a
forall a. WrapState a -> WrappedLine a
wrapCurLine WrapState a
st)
           , wrapCurCol :: Int
wrapCurCol = Int
0
           }

-- | Given a maximum width and an inline sequence, produce a sequence of
-- lines wrapped at the specified column. This only returns lines longer
-- than the maximum width when those lines have a single inline value
-- that cannot be broken down further (such as a long URL).
doLineWrapping :: Int -> Seq (FlattenedValue a) -> Seq (WrappedLine a)
doLineWrapping :: Int -> Seq (FlattenedValue a) -> Seq (Seq (FlattenedValue a))
doLineWrapping Int
maxCols Seq (FlattenedValue a)
i =
    Seq (Seq (FlattenedValue a))
result
    where
        result :: Seq (Seq (FlattenedValue a))
result = WrapState a -> Seq (Seq (FlattenedValue a))
forall a. WrapState a -> Seq (WrappedLine a)
wrapCompletedLines (WrapState a -> Seq (Seq (FlattenedValue a)))
-> WrapState a -> Seq (Seq (FlattenedValue a))
forall a b. (a -> b) -> a -> b
$ State (WrapState a) () -> WrapState a -> WrapState a
forall s a. State s a -> s -> s
execState ((FlattenedValue a -> State (WrapState a) ())
-> Seq (FlattenedValue a) -> State (WrapState a) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FlattenedValue a -> State (WrapState a) ()
forall a. FlattenedValue a -> WrapM () a
pushValue Seq (FlattenedValue a)
i State (WrapState a) ()
-> State (WrapState a) () -> State (WrapState a) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> State (WrapState a) ()
forall a. WrapM () a
pushLine) WrapState a
forall a. WrapState a
initialState
        initialState :: WrapState a
initialState = WrapState :: forall a.
Seq (WrappedLine a) -> WrappedLine a -> Int -> Int -> WrapState a
WrapState { wrapCurLine :: WrappedLine a
wrapCurLine = WrappedLine a
forall a. Monoid a => a
mempty
                                 , wrapCompletedLines :: Seq (WrappedLine a)
wrapCompletedLines = Seq (WrappedLine a)
forall a. Monoid a => a
mempty
                                 , wrapCurCol :: Int
wrapCurCol = Int
0
                                 , wrapWidth :: Int
wrapWidth = Int
maxCols
                                 }

-- The widths returned by this function must match the content widths
-- rendered by renderFlattenedValue.
fvWidth :: FlattenedValue a -> Int
fvWidth :: FlattenedValue a -> Int
fvWidth (SingleInline FlattenedInline a
fi) = FlattenedInline a -> Int
forall a. FlattenedInline a -> Int
fiWidth FlattenedInline a
fi
fvWidth (NonBreaking Seq (Seq (FlattenedValue a))
rs) = Seq Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Seq Int -> Int) -> Seq Int -> Int
forall a b. (a -> b) -> a -> b
$ (Seq Int -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Seq Int -> Int)
-> (Seq (FlattenedValue a) -> Seq Int)
-> Seq (FlattenedValue a)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlattenedValue a -> Int) -> Seq (FlattenedValue a) -> Seq Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlattenedValue a -> Int
forall a. FlattenedValue a -> Int
fvWidth) (Seq (FlattenedValue a) -> Int)
-> Seq (Seq (FlattenedValue a)) -> Seq Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Seq (FlattenedValue a))
rs

-- The widths returned by this function must match the content widths
-- rendered by renderFlattenedValue.
fiWidth :: FlattenedInline a -> Int
fiWidth :: FlattenedInline a -> Int
fiWidth FlattenedInline a
fi =
    case FlattenedInline a -> FlattenedContent
forall a. FlattenedInline a -> FlattenedContent
fiValue FlattenedInline a
fi of
        FText Text
t                      -> Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
t
        FlattenedContent
FSpace                       -> Int
1
        FUser Text
t                      -> Text -> Int
T.length Text
userSigil Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
t
        FChannel Text
t                   -> Text -> Int
T.length Text
normalChannelSigil Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
t
        FEmoji Text
t                     -> Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
        FEditSentinel Bool
_              -> Text -> Int
forall a. TextWidth a => a -> Int
B.textWidth Text
editMarking