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 = 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 = wrapCurLine st |> i
, wrapCurCol = wrapCurCol st + 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
pushLine :: WrapM () a
pushLine :: forall a. 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 = mempty
, wrapCompletedLines = wrapCompletedLines st |> trimLeadingWhitespace (wrapCurLine st)
, wrapCurCol = 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 = 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 a b.
StateT (WrapState a) Identity a
-> StateT (WrapState a) Identity b
-> StateT (WrapState a) Identity b
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 { 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
}
fvWidth :: FlattenedValue a -> Int
fvWidth :: forall a. 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 a. Num a => Seq a -> a
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 a. Num a => Seq a -> a
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 a b. (a -> b) -> Seq a -> Seq b
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
fiWidth :: FlattenedInline a -> Int
fiWidth :: forall a. 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