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
, WrapState -> WrappedLine
wrapCurLine :: WrappedLine
, WrapState -> Int
wrapCurCol :: Int
, WrapState -> Int
wrapWidth :: Int
}
type WrapM a = State WrapState a
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
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
}
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
}
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
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