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 { forall a. WrapState a -> Seq (WrappedLine a)
wrapCompletedLines :: Seq (WrappedLine a)
, forall a. WrapState a -> WrappedLine a
wrapCurLine :: (WrappedLine a)
, forall a. WrapState a -> Int
wrapCurCol :: Int
, forall a. WrapState a -> Int
wrapWidth :: Int
}
type WrapM a b = State (WrapState b) a
pushValue :: FlattenedValue a -> WrapM () a
pushValue :: forall a. FlattenedValue a -> WrapM () a
pushValue FlattenedValue a
i = do
let iw :: Int
iw = forall a. FlattenedValue a -> Int
fvWidth FlattenedValue a
i
pushThisInline :: WrapM () a
pushThisInline =
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WrapState a
st -> WrapState a
st { wrapCurLine :: WrappedLine a
wrapCurLine = forall a. WrapState a -> WrappedLine a
wrapCurLine WrapState a
st forall a. Seq a -> a -> Seq a
|> FlattenedValue a
i
, wrapCurCol :: Int
wrapCurCol = forall a. WrapState a -> Int
wrapCurCol WrapState a
st forall a. Num a => a -> a -> a
+ Int
iw
}
Int
maxWidth <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. WrapState a -> Int
wrapWidth
Int
curWidth <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. WrapState a -> Int
wrapCurCol
let remaining :: Int
remaining = Int
maxWidth forall a. Num a => a -> a -> a
- Int
curWidth
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
iw forall a. Ord a => a -> a -> Bool
> Int
remaining) forall a. WrapM () a
pushLine
WrapM () a
pushThisInline
pushLine :: WrapM () a
pushLine :: forall a. WrapM () a
pushLine = do
let trimLeadingWhitespace :: Seq (FlattenedValue a) -> Seq (FlattenedValue a)
trimLeadingWhitespace Seq (FlattenedValue a)
s =
case forall a. Seq a -> ViewL a
Seq.viewl Seq (FlattenedValue a)
s of
SingleInline FlattenedInline a
i :< Seq (FlattenedValue a)
t | forall a. FlattenedInline a -> FlattenedContent
fiValue FlattenedInline a
i 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
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WrapState a
st ->
WrapState a
st { wrapCurLine :: WrappedLine a
wrapCurLine = forall a. Monoid a => a
mempty
, wrapCompletedLines :: Seq (WrappedLine a)
wrapCompletedLines = forall a. WrapState a -> Seq (WrappedLine a)
wrapCompletedLines WrapState a
st forall a. Seq a -> a -> Seq a
|> forall {a}. Seq (FlattenedValue a) -> Seq (FlattenedValue a)
trimLeadingWhitespace (forall a. WrapState a -> WrappedLine a
wrapCurLine WrapState a
st)
, wrapCurCol :: Int
wrapCurCol = Int
0
}
doLineWrapping :: Int -> Seq (FlattenedValue a) -> Seq (WrappedLine a)
doLineWrapping :: forall a.
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 = forall a. WrapState a -> Seq (WrappedLine a)
wrapCompletedLines forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. FlattenedValue a -> WrapM () a
pushValue Seq (FlattenedValue a)
i forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. WrapM () a
pushLine) forall {a}. WrapState a
initialState
initialState :: WrapState a
initialState = WrapState { wrapCurLine :: WrappedLine a
wrapCurLine = forall a. Monoid a => a
mempty
, wrapCompletedLines :: Seq (WrappedLine a)
wrapCompletedLines = forall a. Monoid a => a
mempty
, wrapCurCol :: Int
wrapCurCol = Int
0
, wrapWidth :: Int
wrapWidth = Int
maxCols
}
fvWidth :: FlattenedValue a -> Int
fvWidth :: forall a. FlattenedValue a -> Int
fvWidth (SingleInline FlattenedInline a
fi) = forall a. FlattenedInline a -> Int
fiWidth FlattenedInline a
fi
fvWidth (NonBreaking Seq (Seq (FlattenedValue a))
rs) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FlattenedValue a -> Int
fvWidth) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Seq (FlattenedValue a))
rs
fiWidth :: FlattenedInline a -> Int
fiWidth :: forall a. FlattenedInline a -> Int
fiWidth FlattenedInline a
fi =
case forall a. FlattenedInline a -> FlattenedContent
fiValue FlattenedInline a
fi of
FText Text
t -> forall a. TextWidth a => a -> Int
B.textWidth Text
t
FlattenedContent
FSpace -> Int
1
FUser Text
t -> Text -> Int
T.length Text
userSigil forall a. Num a => a -> a -> a
+ forall a. TextWidth a => a -> Int
B.textWidth Text
t
FChannel Text
t -> Text -> Int
T.length Text
normalChannelSigil forall a. Num a => a -> a -> a
+ forall a. TextWidth a => a -> Int
B.textWidth Text
t
FEmoji Text
t -> forall a. TextWidth a => a -> Int
B.textWidth Text
t forall a. Num a => a -> a -> a
+ Int
2
FEditSentinel Bool
_ -> forall a. TextWidth a => a -> Int
B.textWidth Text
editMarking