-- | 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 = Seq FlattenedValue

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

type WrapM a = State WrapState 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 -> WrapM ()
pushValue :: FlattenedValue -> WrapM ()
pushValue FlattenedValue
i = do
    let iw :: Int
iw = FlattenedValue -> Int
fvWidth FlattenedValue
i
        pushThisInline :: WrapM ()
pushThisInline =
            (WrapState -> WrapState) -> WrapM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WrapState -> WrapState) -> WrapM ())
-> (WrapState -> WrapState) -> WrapM ()
forall a b. (a -> b) -> a -> b
$ \WrapState
st -> WrapState
st { wrapCurLine :: WrappedLine
wrapCurLine = WrapState -> WrappedLine
wrapCurLine WrapState
st WrappedLine -> FlattenedValue -> WrappedLine
forall a. Seq a -> a -> Seq a
|> FlattenedValue
i
                               , wrapCurCol :: Int
wrapCurCol = WrapState -> Int
wrapCurCol WrapState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
iw
                               }
    Int
maxWidth <- (WrapState -> Int) -> StateT WrapState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WrapState -> Int
wrapWidth
    Int
curWidth <- (WrapState -> Int) -> StateT WrapState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WrapState -> Int
wrapCurCol
    let remaining :: Int
remaining = Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curWidth

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

    WrapM ()
pushThisInline

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

    (WrapState -> WrapState) -> WrapM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WrapState -> WrapState) -> WrapM ())
-> (WrapState -> WrapState) -> WrapM ()
forall a b. (a -> b) -> a -> b
$ \WrapState
st ->
        WrapState
st { wrapCurLine :: WrappedLine
wrapCurLine = WrappedLine
forall a. Monoid a => a
mempty
           , wrapCompletedLines :: Seq WrappedLine
wrapCompletedLines = WrapState -> Seq WrappedLine
wrapCompletedLines WrapState
st Seq WrappedLine -> WrappedLine -> Seq WrappedLine
forall a. Seq a -> a -> Seq a
|> WrappedLine -> WrappedLine
trimLeadingWhitespace (WrapState -> WrappedLine
wrapCurLine WrapState
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 -> Seq WrappedLine
doLineWrapping :: Int -> WrappedLine -> Seq WrappedLine
doLineWrapping Int
maxCols WrappedLine
i =
    Seq WrappedLine
result
    where
        result :: Seq WrappedLine
result = WrapState -> Seq WrappedLine
wrapCompletedLines (WrapState -> Seq WrappedLine) -> WrapState -> Seq WrappedLine
forall a b. (a -> b) -> a -> b
$ WrapM () -> WrapState -> WrapState
forall s a. State s a -> s -> s
execState ((FlattenedValue -> WrapM ()) -> WrappedLine -> WrapM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FlattenedValue -> WrapM ()
pushValue WrappedLine
i WrapM () -> WrapM () -> WrapM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WrapM ()
pushLine) WrapState
initialState
        initialState :: WrapState
initialState = WrapState :: Seq WrappedLine -> WrappedLine -> Int -> Int -> WrapState
WrapState { wrapCurLine :: WrappedLine
wrapCurLine = WrappedLine
forall a. Monoid a => a
mempty
                                 , wrapCompletedLines :: Seq WrappedLine
wrapCompletedLines = Seq WrappedLine
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 -> Int
fvWidth :: FlattenedValue -> Int
fvWidth (SingleInline FlattenedInline
fi) = FlattenedInline -> Int
fiWidth FlattenedInline
fi
fvWidth (NonBreaking Seq WrappedLine
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) -> (WrappedLine -> Seq Int) -> WrappedLine -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlattenedValue -> Int) -> WrappedLine -> Seq Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FlattenedValue -> Int
fvWidth) (WrappedLine -> Int) -> Seq WrappedLine -> Seq Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq WrappedLine
rs

-- The widths returned by this function must match the content widths
-- rendered by renderFlattenedValue.
fiWidth :: FlattenedInline -> Int
fiWidth :: FlattenedInline -> Int
fiWidth FlattenedInline
fi =
    case FlattenedInline -> FlattenedContent
fiValue FlattenedInline
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