{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
module Graphics.Vty.PictureToSpans
( displayOpsForPic
)
where
import Graphics.Vty.Attributes (Attr, currentAttr)
import Graphics.Vty.Image
import Graphics.Vty.Image.Internal
import Graphics.Vty.Picture
import Graphics.Vty.Span
import Lens.Micro
import Lens.Micro.Mtl
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Strict hiding ( state )
import Control.Monad.ST.Strict
import qualified Data.Vector as Vector hiding ( take, replicate )
import Data.Vector.Mutable ( MVector(..))
import qualified Data.Vector.Mutable as MVector
import qualified Data.Text.Lazy as TL
type MRowOps s = MVector s SpanOps
data BlitState = BlitState
{ BlitState -> Int
_columnOffset :: Int
, BlitState -> Int
_rowOffset :: Int
, BlitState -> Int
_skipColumns :: Int
, BlitState -> Int
_skipRows :: Int
, BlitState -> Int
_remainingColumns :: Int
, BlitState -> Int
_remainingRows :: Int
}
columnOffset :: Lens' BlitState Int
columnOffset :: Lens' BlitState Int
columnOffset = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_columnOffset (\BlitState
e Int
v -> BlitState
e { _columnOffset = v })
rowOffset :: Lens' BlitState Int
rowOffset :: Lens' BlitState Int
rowOffset = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_rowOffset (\BlitState
e Int
v -> BlitState
e { _rowOffset = v })
skipColumns :: Lens' BlitState Int
skipColumns :: Lens' BlitState Int
skipColumns = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_skipColumns (\BlitState
e Int
v -> BlitState
e { _skipColumns = v })
skipRows :: Lens' BlitState Int
skipRows :: Lens' BlitState Int
skipRows = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_skipRows (\BlitState
e Int
v -> BlitState
e { _skipRows = v })
remainingColumns :: Lens' BlitState Int
remainingColumns :: Lens' BlitState Int
remainingColumns = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_remainingColumns (\BlitState
e Int
v -> BlitState
e { _remainingColumns = v })
remainingRows :: Lens' BlitState Int
remainingRows :: Lens' BlitState Int
remainingRows = (BlitState -> Int)
-> (BlitState -> Int -> BlitState) -> Lens' BlitState Int
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitState -> Int
_remainingRows (\BlitState
e Int
v -> BlitState
e { _remainingRows = v })
data BlitEnv s = BlitEnv
{ forall s. BlitEnv s -> DisplayRegion
_region :: DisplayRegion
, forall s. BlitEnv s -> MRowOps s
_mrowOps :: MRowOps s
}
region :: Lens' (BlitEnv s) DisplayRegion
region :: forall s (f :: * -> *).
Functor f =>
(DisplayRegion -> f DisplayRegion) -> BlitEnv s -> f (BlitEnv s)
region = (BlitEnv s -> DisplayRegion)
-> (BlitEnv s -> DisplayRegion -> BlitEnv s)
-> Lens (BlitEnv s) (BlitEnv s) DisplayRegion DisplayRegion
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitEnv s -> DisplayRegion
forall s. BlitEnv s -> DisplayRegion
_region (\BlitEnv s
e DisplayRegion
r -> BlitEnv s
e { _region = r })
mrowOps :: Lens' (BlitEnv s) (MRowOps s)
mrowOps :: forall s (f :: * -> *).
Functor f =>
(MRowOps s -> f (MRowOps s)) -> BlitEnv s -> f (BlitEnv s)
mrowOps = (BlitEnv s -> MRowOps s)
-> (BlitEnv s -> MRowOps s -> BlitEnv s)
-> Lens (BlitEnv s) (BlitEnv s) (MRowOps s) (MRowOps s)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens BlitEnv s -> MRowOps s
forall s. BlitEnv s -> MRowOps s
_mrowOps (\BlitEnv s
e MRowOps s
r -> BlitEnv s
e { _mrowOps = r })
type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps
displayOpsForPic Picture
pic DisplayRegion
r = (forall s. ST s (MVector s SpanOps)) -> DisplayOps
forall a. (forall s. ST s (MVector s a)) -> Vector a
Vector.create (Picture -> DisplayRegion -> ST s (MRowOps s)
forall s. Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers Picture
pic DisplayRegion
r)
combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers :: forall s. Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers Picture
pic DisplayRegion
r
| DisplayRegion -> Int
regionWidth DisplayRegion
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| DisplayRegion -> Int
regionHeight DisplayRegion
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> ST s (MVector (PrimState (ST s)) SpanOps)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MVector.new Int
0
| Bool
otherwise = do
[MVector s SpanOps]
layerOps <- (Image -> ST s (MVector s SpanOps))
-> [Image] -> ST s [MVector s SpanOps]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Image -> DisplayRegion -> ST s (MVector s SpanOps)
forall s. Image -> DisplayRegion -> ST s (MRowOps s)
`buildSpans` DisplayRegion
r) (Picture -> [Image]
picLayers Picture
pic)
case [MVector s SpanOps]
layerOps of
[] -> [Char] -> ST s (MVector s SpanOps)
forall a. HasCallStack => [Char] -> a
error [Char]
"empty picture"
[MVector s SpanOps
ops] -> Background -> MVector s SpanOps -> ST s (MVector s SpanOps)
forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MVector s SpanOps
ops
MVector s SpanOps
topOps : [MVector s SpanOps]
lowerOps -> do
MVector s SpanOps
ops <- (MVector s SpanOps
-> MVector s SpanOps -> ST s (MVector s SpanOps))
-> MVector s SpanOps
-> [MVector s SpanOps]
-> ST s (MVector s SpanOps)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MVector s SpanOps -> MVector s SpanOps -> ST s (MVector s SpanOps)
forall s. MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder MVector s SpanOps
topOps [MVector s SpanOps]
lowerOps
Background -> MVector s SpanOps -> ST s (MVector s SpanOps)
forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MVector s SpanOps
ops
substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips :: forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips Background
ClearBackground MRowOps s
ops = do
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
ops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
SpanOps
rowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row
let rowOps' :: SpanOps
rowOps' = case SpanOps -> SpanOp
forall a. Vector a -> a
Vector.last SpanOps
rowOps of
Skip Int
w -> SpanOps -> SpanOps
forall a. Vector a -> Vector a
Vector.init SpanOps
rowOps SpanOps -> SpanOp -> SpanOps
forall a. Vector a -> a -> Vector a
`Vector.snoc` Int -> SpanOp
RowEnd Int
w
SpanOp
_ -> SpanOps
rowOps
let rowOps'' :: SpanOps
rowOps'' = Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
' ' Attr
currentAttr SpanOps
rowOps'
MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row SpanOps
rowOps''
MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops
substituteSkips (Background {Char
backgroundChar :: Char
backgroundChar :: Background -> Char
backgroundChar, Attr
backgroundAttr :: Attr
backgroundAttr :: Background -> Attr
backgroundAttr}) MRowOps s
ops = do
case Char -> Int
safeWcwidth Char
backgroundChar of
Int
w | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> [Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ST s ()) -> [Char] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid background character " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. Show a => a -> [Char]
show Char
backgroundChar
| Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
ops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
SpanOps
rowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row
let rowOps' :: SpanOps
rowOps' = Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
backgroundChar Attr
backgroundAttr SpanOps
rowOps
MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row SpanOps
rowOps'
| Bool
otherwise -> do
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
ops Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
SpanOps
rowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row
let rowOps' :: SpanOps
rowOps' = Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan Int
w Char
backgroundChar Attr
backgroundAttr SpanOps
rowOps
MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
ops Int
row SpanOps
rowOps'
MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops
mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder :: forall s. MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder MRowOps s
upper MRowOps s
lower = do
[Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. MRowOps s -> Int
forall s a. MVector s a -> Int
MVector.length MRowOps s
upper Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
row -> do
SpanOps
upperRowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
upper Int
row
SpanOps
lowerRowOps <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
lower Int
row
let rowOps :: SpanOps
rowOps = SpanOps -> SpanOps -> SpanOps
mergeRowUnder SpanOps
upperRowOps SpanOps
lowerRowOps
MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
upper Int
row SpanOps
rowOps
MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
upper
mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
mergeRowUnder :: SpanOps -> SpanOps -> SpanOps
mergeRowUnder SpanOps
upperRowOps =
SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
forall a. Vector a
Vector.empty (SpanOps -> SpanOp
forall a. Vector a -> a
Vector.head SpanOps
upperRowOps) (SpanOps -> SpanOps
forall a. Vector a -> Vector a
Vector.tail SpanOps
upperRowOps)
where
onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps op :: SpanOp
op@(TextSpan Attr
_ Int
w Int
_ Text
_) SpanOps
upperOps SpanOps
lowerOps =
let lowerOps' :: SpanOps
lowerOps' = Int -> SpanOps -> SpanOps
dropOps Int
w SpanOps
lowerOps
outOps' :: SpanOps
outOps' = SpanOps -> SpanOp -> SpanOps
forall a. Vector a -> a -> Vector a
Vector.snoc SpanOps
outOps SpanOp
op
in if SpanOps -> Bool
forall a. Vector a -> Bool
Vector.null SpanOps
lowerOps'
then SpanOps
outOps'
else SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps' (SpanOps -> SpanOp
forall a. Vector a -> a
Vector.head SpanOps
upperOps) (SpanOps -> SpanOps
forall a. Vector a -> Vector a
Vector.tail SpanOps
upperOps) SpanOps
lowerOps'
onUpperOp SpanOps
outOps (Skip Int
w) SpanOps
upperOps SpanOps
lowerOps =
let (SpanOps
ops', SpanOps
lowerOps') = Int -> SpanOps -> (SpanOps, SpanOps)
splitOpsAt Int
w SpanOps
lowerOps
outOps' :: SpanOps
outOps' = SpanOps
outOps SpanOps -> SpanOps -> SpanOps
forall a. Monoid a => a -> a -> a
`mappend` SpanOps
ops'
in if SpanOps -> Bool
forall a. Vector a -> Bool
Vector.null SpanOps
lowerOps'
then SpanOps
outOps'
else SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps' (SpanOps -> SpanOp
forall a. Vector a -> a
Vector.head SpanOps
upperOps) (SpanOps -> SpanOps
forall a. Vector a -> Vector a
Vector.tail SpanOps
upperOps) SpanOps
lowerOps'
onUpperOp SpanOps
_ (RowEnd Int
_) SpanOps
_ SpanOps
_ = [Char] -> SpanOps
forall a. HasCallStack => [Char] -> a
error [Char]
"cannot merge rows containing RowEnd ops"
swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps
swapSkipsForSingleColumnCharSpan Char
c Attr
a = (SpanOp -> SpanOp) -> SpanOps -> SpanOps
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map SpanOp -> SpanOp
f
where f :: SpanOp -> SpanOp
f (Skip Int
ow) = let txt :: Text
txt = [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
ow Char
c
in Attr -> Int -> Int -> Text -> SpanOp
TextSpan Attr
a Int
ow Int
ow Text
txt
f SpanOp
v = SpanOp
v
swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps
swapSkipsForCharSpan Int
w Char
c Attr
a = (SpanOp -> SpanOp) -> SpanOps -> SpanOps
forall a b. (a -> b) -> Vector a -> Vector b
Vector.map SpanOp -> SpanOp
f
where
f :: SpanOp -> SpanOp
f (Skip Int
ow) = let txt0Cw :: Int
txt0Cw = Int
ow Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
w
txt0 :: Text
txt0 = [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
txt0Cw Char
c
txt1Cw :: Int
txt1Cw = Int
ow Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
w
txt1 :: Text
txt1 = [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
txt1Cw Char
'…'
cw :: Int
cw = Int
txt0Cw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
txt1Cw
txt :: Text
txt = Text
txt0 Text -> Text -> Text
`TL.append` Text
txt1
in Attr -> Int -> Int -> Text -> SpanOp
TextSpan Attr
a Int
ow Int
cw Text
txt
f SpanOp
v = SpanOp
v
buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
buildSpans :: forall s. Image -> DisplayRegion -> ST s (MRowOps s)
buildSpans Image
image DisplayRegion
outRegion = do
MRowOps s
outOps <- Int -> SpanOps -> ST s (MVector (PrimState (ST s)) SpanOps)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MVector.replicate (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion) SpanOps
forall a. Vector a
Vector.empty
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& DisplayRegion -> Int
regionWidth DisplayRegion
outRegion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
let fullBuild :: ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
fullBuild = do
Image -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Image -> BlitM s ()
startImageBuild Image
image
[Int]
-> (Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] (DisplayRegion
-> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. DisplayRegion -> Int -> BlitM s ()
addRowCompletion DisplayRegion
outRegion)
initEnv :: BlitEnv s
initEnv = DisplayRegion -> MRowOps s -> BlitEnv s
forall s. DisplayRegion -> MRowOps s -> BlitEnv s
BlitEnv DisplayRegion
outRegion MRowOps s
outOps
initState :: BlitState
initState = Int -> Int -> Int -> Int -> Int -> Int -> BlitState
BlitState Int
0 Int
0 Int
0 Int
0 (DisplayRegion -> Int
regionWidth DisplayRegion
outRegion) (DisplayRegion -> Int
regionHeight DisplayRegion
outRegion)
((), BlitState)
_ <- StateT BlitState (ST s) () -> BlitState -> ST s ((), BlitState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> BlitEnv s -> StateT BlitState (ST s) ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall {s}. ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
fullBuild BlitEnv s
initEnv) BlitState
initState
() -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
MRowOps s -> ST s (MRowOps s)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
outOps
startImageBuild :: Image -> BlitM s ()
startImageBuild :: forall s. Image -> BlitM s ()
startImageBuild Image
image = do
Bool
outOfBounds <- Image -> BlitState -> Bool
isOutOfBounds Image
image (BlitState -> Bool)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
forall s (m :: * -> *). MonadState s m => m s
get
Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
outOfBounds) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
image
isOutOfBounds :: Image -> BlitState -> Bool
isOutOfBounds :: Image -> BlitState -> Bool
isOutOfBounds Image
i BlitState
s
| BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
remainingColumns Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Bool
True
| BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
remainingRows Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Bool
True
| BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
skipColumns Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Image -> Int
imageWidth Image
i = Bool
True
| BlitState
s BlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int BlitState Int
Lens' BlitState Int
skipRows Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Image -> Int
imageHeight Image
i = Bool
True
| Bool
otherwise = Bool
False
addMaybeClipped :: forall s . Image -> BlitM s ()
addMaybeClipped :: forall s. Image -> BlitM s ()
addMaybeClipped Image
EmptyImage = () -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a. a -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addMaybeClipped (HorizText Attr
a Text
textStr Int
ow Int
_cw) = do
Int
s <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipRows
Bool
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$ do
Int
leftClip <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipColumns
Int
rightClip <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
remainingColumns
let leftClipped :: Bool
leftClipped = Int
leftClip Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
rightClipped :: Bool
rightClipped = (Int
ow Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftClip) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
rightClip
if Bool
leftClipped Bool -> Bool -> Bool
|| Bool
rightClipped
then let textStr' :: Text
textStr' = Text -> Int -> Int -> Text
clipText Text
textStr Int
leftClip Int
rightClip
in Attr -> Text -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
textStr'
else Attr -> Text -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
textStr
addMaybeClipped (VertJoin Image
topImage Image
bottomImage Int
_ow Int
oh) = do
Bool
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
imageHeight Image
topImage Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Image -> Int
imageHeight Image
bottomImage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
"vert_join" (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
skipRows (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
remainingRows (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
rowOffset
(Image -> Int
imageHeight Image
topImage)
Image
topImage
Image
bottomImage
Int
oh
addMaybeClipped (HorizJoin Image
leftImage Image
rightImage Int
ow Int
_oh) = do
Bool
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Image -> Int
imageWidth Image
leftImage Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Image -> Int
imageWidth Image
rightImage Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
"horiz_join" (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
skipColumns (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
remainingColumns (Int -> f Int) -> BlitState -> f BlitState
Lens' BlitState Int
columnOffset
(Image -> Int
imageWidth Image
leftImage)
Image
leftImage
Image
rightImage
Int
ow
addMaybeClipped BGFill {Int
outputWidth :: Int
outputWidth :: Image -> Int
outputWidth, Int
outputHeight :: Int
outputHeight :: Image -> Int
outputHeight} = do
BlitState
s <- ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
forall s (m :: * -> *). MonadState s m => m s
get
let outputWidth' :: Int
outputWidth' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
skipColumns) (BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remainingColumns)
outputHeight' :: Int
outputHeight' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
skipRows ) (BlitState
sBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remainingRows)
Int
y <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
rowOffset
[Int]
-> (Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
y..Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
outputHeight'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> (Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ())
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall a b. (a -> b) -> a -> b
$ SpanOp -> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. SpanOp -> Int -> BlitM s ()
snocOp (Int -> SpanOp
Skip Int
outputWidth')
addMaybeClipped Crop {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
leftSkip :: Int
leftSkip :: Image -> Int
leftSkip, Int
topSkip :: Int
topSkip :: Image -> Int
topSkip, Int
outputWidth :: Image -> Int
outputWidth :: Int
outputWidth, Int
outputHeight :: Image -> Int
outputHeight :: Int
outputHeight} = do
Int
sx <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipColumns
(Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skipColumns ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
leftSkip
((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remainingColumns (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sx))
Int
sy <- Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
skipRows
(Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skipRows ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
topSkip
((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remainingRows (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
outputHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sy))
Image -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClippedJoin :: forall s . String
-> Lens BlitState BlitState Int Int
-> Lens BlitState BlitState Int Int
-> Lens BlitState BlitState Int Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin :: forall s.
[Char]
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin [Char]
name Lens' BlitState Int
skip Lens' BlitState Int
remaining Lens' BlitState Int
offset Int
i0Dim Image
i0 Image
i1 Int
size = do
BlitState
state <- ReaderT (BlitEnv s) (StateT BlitState (ST s)) BlitState
forall s (m :: * -> *). MonadState s m => m s
get
Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> BlitM s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> BlitM s ()) -> [Char] -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with remaining <= 0"
case BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
skip of
Int
s | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
size -> BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skip ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
size
| Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> if BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i0Dim
then do
Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
offset ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i0Dim) BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remaining ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
i0Dim
Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
else Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
| Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i0Dim ->
let i0Dim' :: Int
i0Dim' = Int
i0Dim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s
in if BlitState
stateBlitState -> Getting Int BlitState Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int BlitState Int
Lens' BlitState Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
i0Dim'
then Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
else do
Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i0
BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
offset ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i0Dim') BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remaining ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
i0Dim' BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skip ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
0
Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
| Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i0Dim -> do
BlitState -> BlitM s ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BlitState -> BlitM s ()) -> BlitState -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ BlitState
state BlitState -> (BlitState -> BlitState) -> BlitState
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skip ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> (Int -> Int) -> BlitState -> BlitState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
i0Dim
Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
i1
Int
_ -> [Char] -> BlitM s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> BlitM s ()) -> [Char] -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" has unhandled skip class"
addUnclippedText :: Attr -> TL.Text -> BlitM s ()
addUnclippedText :: forall s. Attr -> Text -> BlitM s ()
addUnclippedText Attr
a Text
txt = do
let op :: SpanOp
op = Attr -> Int -> Int -> Text -> SpanOp
TextSpan Attr
a Int
usedDisplayColumns
(Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
TL.length Text
txt)
Text
txt
usedDisplayColumns :: Int
usedDisplayColumns = Text -> Int
wctlwidth Text
txt
Getting Int BlitState Int
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int BlitState Int
Lens' BlitState Int
rowOffset ReaderT (BlitEnv s) (StateT BlitState (ST s)) Int
-> (Int -> BlitM s ()) -> BlitM s ()
forall a b.
ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
-> (a -> ReaderT (BlitEnv s) (StateT BlitState (ST s)) b)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanOp -> Int -> BlitM s ()
forall s. SpanOp -> Int -> BlitM s ()
snocOp SpanOp
op
addRowCompletion :: DisplayRegion -> Int -> BlitM s ()
addRowCompletion :: forall s. DisplayRegion -> Int -> BlitM s ()
addRowCompletion DisplayRegion
displayRegion Int
row = do
MRowOps s
allRowOps <- Getting (MRowOps s) (BlitEnv s) (MRowOps s)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) (MRowOps s)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MRowOps s) (BlitEnv s) (MRowOps s)
forall s (f :: * -> *).
Functor f =>
(MRowOps s -> f (MRowOps s)) -> BlitEnv s -> f (BlitEnv s)
mrowOps
SpanOps
rowOps <- StateT BlitState (ST s) SpanOps
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps
forall (m :: * -> *) a. Monad m => m a -> ReaderT (BlitEnv s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BlitState (ST s) SpanOps
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps)
-> StateT BlitState (ST s) SpanOps
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps
forall a b. (a -> b) -> a -> b
$ ST s SpanOps -> StateT BlitState (ST s) SpanOps
forall (m :: * -> *) a. Monad m => m a -> StateT BlitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s SpanOps -> StateT BlitState (ST s) SpanOps)
-> ST s SpanOps -> StateT BlitState (ST s) SpanOps
forall a b. (a -> b) -> a -> b
$ MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
allRowOps Int
row
let endX :: Int
endX = SpanOps -> Int
spanOpsAffectedColumns SpanOps
rowOps
Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
endX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< DisplayRegion -> Int
regionWidth DisplayRegion
displayRegion) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ do
let ow :: Int
ow = DisplayRegion -> Int
regionWidth DisplayRegion
displayRegion Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endX
SpanOp -> Int -> BlitM s ()
forall s. SpanOp -> Int -> BlitM s ()
snocOp (Int -> SpanOp
Skip Int
ow) Int
row
snocOp :: SpanOp -> Int -> BlitM s ()
snocOp :: forall s. SpanOp -> Int -> BlitM s ()
snocOp !SpanOp
op !Int
row = do
MRowOps s
theMrowOps <- Getting (MRowOps s) (BlitEnv s) (MRowOps s)
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) (MRowOps s)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MRowOps s) (BlitEnv s) (MRowOps s)
forall s (f :: * -> *).
Functor f =>
(MRowOps s -> f (MRowOps s)) -> BlitEnv s -> f (BlitEnv s)
mrowOps
DisplayRegion
theRegion <- Getting DisplayRegion (BlitEnv s) DisplayRegion
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) DisplayRegion
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DisplayRegion (BlitEnv s) DisplayRegion
forall s (f :: * -> *).
Functor f =>
(DisplayRegion -> f DisplayRegion) -> BlitEnv s -> f (BlitEnv s)
region
StateT BlitState (ST s) () -> BlitM s ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT (BlitEnv s) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT BlitState (ST s) () -> BlitM s ())
-> StateT BlitState (ST s) () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ ST s () -> StateT BlitState (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> StateT BlitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT BlitState (ST s) ())
-> ST s () -> StateT BlitState (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
SpanOps
ops <- MVector (PrimState (ST s)) SpanOps -> Int -> ST s SpanOps
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MVector.read MRowOps s
MVector (PrimState (ST s)) SpanOps
theMrowOps Int
row
let ops' :: SpanOps
ops' = SpanOps -> SpanOp -> SpanOps
forall a. Vector a -> a -> Vector a
Vector.snoc SpanOps
ops SpanOp
op
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SpanOps -> Int
spanOpsAffectedColumns SpanOps
ops' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> DisplayRegion -> Int
regionWidth DisplayRegion
theRegion)
(ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> ST s ()) -> [Char] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char]
"row " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
row [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" now exceeds region width"
MVector (PrimState (ST s)) SpanOps -> Int -> SpanOps -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MVector.write MRowOps s
MVector (PrimState (ST s)) SpanOps
theMrowOps Int
row SpanOps
ops'