Wrap.hs

-- | 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 { wrapCompletedLines :: Seq (WrappedLine a)
              -- ^ The completed lines so far
              , wrapCurLine :: (WrappedLine a)
              -- ^ The current line we are accumulating
              , wrapCurCol :: Int
              -- ^ The width of wrapCurLine, in columns
              , 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 i = do
    let iw = fvWidth i
        pushThisInline =
            modify $ \st -> st { wrapCurLine = wrapCurLine st |> i
                               , wrapCurCol = wrapCurCol st + iw
                               }
    maxWidth <- gets wrapWidth
    curWidth <- gets wrapCurCol
    let remaining = maxWidth - curWidth

    when (iw > remaining) pushLine

    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 = do
    let trimLeadingWhitespace s =
            case Seq.viewl s of
                SingleInline i :< t | fiValue i == FSpace -> trimLeadingWhitespace t
                _ -> s

    modify $ \st ->
        st { wrapCurLine = mempty
           , wrapCompletedLines = wrapCompletedLines st |> trimLeadingWhitespace (wrapCurLine st)
           , wrapCurCol = 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 maxCols i =
    result
    where
        result = wrapCompletedLines $ execState (mapM_ pushValue i >> pushLine) initialState
        initialState = WrapState { wrapCurLine = mempty
                                 , wrapCompletedLines = mempty
                                 , wrapCurCol = 0
                                 , wrapWidth = maxCols
                                 }

-- The widths returned by this function must match the content widths
-- rendered by renderFlattenedValue.
fvWidth :: FlattenedValue a -> Int
fvWidth (SingleInline fi) = fiWidth fi
fvWidth (NonBreaking rs) = sum $ (sum . fmap fvWidth) <$> rs

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