-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Transforms an image into rows of operations.
module Graphics.Vty.PictureToSpans 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 Lens.Micro.TH
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

type MSpanOps s = MVector s SpanOp

-- transform plus clip. More or less.
data BlitState = BlitState
    -- we always snoc to the operation vectors. Thus the columnOffset =
    -- length of row at rowOffset although, one possibility is to merge
    -- layers right in snocOp (naming it something else, of course). In
    -- which case columnnOffset would be applicable. Right now we need
    -- it to exist.
    { BlitState -> Int
_columnOffset :: Int
    , BlitState -> Int
_rowOffset :: Int
    -- clip coordinate space is in image space. Which means it's >= 0
    -- and < imageWidth.
    , BlitState -> Int
_skipColumns :: Int
    -- >= 0 and < imageHeight
    , BlitState -> Int
_skipRows :: Int
    -- includes consideration of skipColumns. In display space. The
    -- number of columns from the next column to be defined to the end
    -- of the display for the row.
    , BlitState -> Int
_remainingColumns :: Int
    -- includes consideration of skipRows. In display space.
    , BlitState -> Int
_remainingRows :: Int
    }

makeLenses ''BlitState

data BlitEnv s = BlitEnv
    { BlitEnv s -> DisplayRegion
_region :: DisplayRegion
    , BlitEnv s -> MRowOps s
_mrowOps :: MRowOps s
    }

makeLenses ''BlitEnv

type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a

-- | Produces the span ops that will render the given picture, possibly
-- cropped or padded, into the specified region.
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)

-- | Returns the DisplayOps for an image rendered to a window the size
-- of the image.
--
-- largerly used only for debugging.
displayOpsForImage :: Image -> DisplayOps
displayOpsForImage :: Image -> DisplayOps
displayOpsForImage Image
i = Picture -> DisplayRegion -> DisplayOps
displayOpsForPic (Image -> Picture
picForImage Image
i) (Image -> Int
imageWidth Image
i, Image -> Int
imageHeight Image
i)

-- | Produces the span ops for each layer then combines them.
combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers :: 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
        [MRowOps s]
layerOps <- (Image -> ST s (MRowOps s)) -> [Image] -> ST s [MRowOps s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Image -> DisplayRegion -> ST s (MRowOps s)
forall s. Image -> DisplayRegion -> ST s (MRowOps s)
`buildSpans` DisplayRegion
r) (Picture -> [Image]
picLayers Picture
pic)
        case [MRowOps s]
layerOps of
            []    -> String -> ST s (MRowOps s)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty picture"
            [MRowOps s
ops] -> Background -> MRowOps s -> ST s (MRowOps s)
forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MRowOps s
ops
            -- instead of merging ops after generation the merging can
            -- be performed as part of snocOp.
            MRowOps s
topOps : [MRowOps s]
lowerOps -> do
                MRowOps s
ops <- (MRowOps s -> MRowOps s -> ST s (MRowOps s))
-> MRowOps s -> [MRowOps s] -> ST s (MRowOps s)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MRowOps s -> MRowOps s -> ST s (MRowOps s)
forall s. MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder MRowOps s
topOps [MRowOps s]
lowerOps
                Background -> MRowOps s -> ST s (MRowOps s)
forall s. Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips (Picture -> Background
picBackground Picture
pic) MRowOps s
ops

substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)
substituteSkips :: 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
        -- the image operations assure that background fills are
        -- combined. clipping a background fill does not split the
        -- background fill. merging of image layers can split a skip,
        -- but only by the insertion of a non skip. all this combines to
        -- mean we can check the last operation and remove it if it's a
        -- skip
        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
        -- now all the skips can be replaced by replications of ' ' of
        -- the required width.
        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 (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops
substituteSkips (Background {Char
backgroundChar :: Background -> Char
backgroundChar :: Char
backgroundChar, Attr
backgroundAttr :: Background -> Attr
backgroundAttr :: Attr
backgroundAttr}) MRowOps s
ops = do
    -- At this point we decide if the background character is single
    -- column or not. obviously, single column is easier.
    case Char -> Int
safeWcwidth Char
backgroundChar of
        Int
w | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> String -> ST s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"invalid background character " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
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 (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
ops

mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s)
mergeUnder :: 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 (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
        -- H: it will never be the case that we are out of upper ops
        -- before lower ops.
        onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
        onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps
onUpperOp SpanOps
outOps op :: SpanOp
op@(TextSpan Attr
_ Int
w Int
_ DisplayText
_) 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
_ = String -> SpanOps
forall a. HasCallStack => String -> a
error String
"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 :: DisplayText
txt = String -> DisplayText
TL.pack (String -> DisplayText) -> String -> DisplayText
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
ow Char
c
                        in Attr -> Int -> Int -> DisplayText -> SpanOp
TextSpan Attr
a Int
ow Int
ow DisplayText
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 :: DisplayText
txt0 = String -> DisplayText
TL.pack (String -> DisplayText) -> String -> DisplayText
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
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 :: DisplayText
txt1 = String -> DisplayText
TL.pack (String -> DisplayText) -> String -> DisplayText
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
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 :: DisplayText
txt = DisplayText
txt0 DisplayText -> DisplayText -> DisplayText
`TL.append` DisplayText
txt1
                      in Attr -> Int -> Int -> DisplayText -> SpanOp
TextSpan Attr
a Int
ow Int
cw DisplayText
txt
        f SpanOp
v = SpanOp
v

-- | Builds a vector of row operations that will output the given
-- picture to the terminal.
--
-- Crops to the given display region.
buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)
buildSpans Image
image DisplayRegion
outRegion = do
    -- First we create a mutable vector for each rows output operations.
    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
    -- It's possible that building the span operations in display order
    -- would provide better performance.
    --
    -- A depth first traversal of the image is performed. ordered
    -- according to the column range defined by the image from least
    -- to greatest. The output row ops will at least have the region
    -- of the image specified. Iterate over all output rows and output
    -- background fills for all unspecified columns.
    --
    -- The images are made into span operations from left to right. It's
    -- possible that this could easily be made to assure top to bottom
    -- output as well.
    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
        -- The ops builder recursively descends the image and outputs
        -- span ops that would display that image. The number of columns
        -- remaining in this row before exceeding the bounds is also
        -- provided. This is used to clip the span ops produced to the
        -- display.
        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
                -- Fill in any unspecified columns with a skip.
                [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 (m :: * -> *) a. Monad m => a -> m a
return ()
    MRowOps s -> ST s (MRowOps s)
forall (m :: * -> *) a. Monad m => a -> m a
return MRowOps s
outOps

-- | Add the operations required to build a given image to the current
-- set of row operations.
startImageBuild :: Image -> BlitM s ()
startImageBuild :: 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

-- | This adds an image that might be partially clipped to the output
-- ops.
--
-- This is a very touchy algorithm. Too touchy. For instance, the
-- CropRight and CropBottom implementations are odd. They pass the
-- current tests but something seems terribly wrong about all this.
addMaybeClipped :: forall s . Image -> BlitM s ()
addMaybeClipped :: Image -> BlitM s ()
addMaybeClipped Image
EmptyImage = () -> BlitM s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
addMaybeClipped (HorizText Attr
a DisplayText
textStr Int
ow Int
_cw) = do
    -- This assumes that text spans are only 1 row high.
    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 -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM 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' :: DisplayText
textStr' = DisplayText -> Int -> Int -> DisplayText
clipText DisplayText
textStr Int
leftClip Int
rightClip
                 in Attr -> DisplayText -> BlitM s ()
forall s. Attr -> DisplayText -> BlitM s ()
addUnclippedText Attr
a DisplayText
textStr'
            else Attr -> DisplayText -> BlitM s ()
forall s. Attr -> DisplayText -> BlitM s ()
addUnclippedText Attr
a DisplayText
textStr
addMaybeClipped (VertJoin Image
topImage Image
bottomImage Int
_ow Int
oh) = do
    Bool -> BlitM s () -> BlitM 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) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$
        String
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
forall s.
String
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin String
"vert_join" Lens' BlitState Int
skipRows Lens' BlitState Int
remainingRows 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 -> BlitM s () -> BlitM 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) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$
        String
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
forall s.
String
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin String
"horiz_join" Lens' BlitState Int
skipColumns Lens' BlitState Int
remainingColumns Lens' BlitState Int
columnOffset
                            (Image -> Int
imageWidth Image
leftImage)
                            Image
leftImage
                            Image
rightImage
                            Int
ow
addMaybeClipped BGFill {Int
outputWidth :: Image -> Int
outputWidth :: Int
outputWidth, Int
outputHeight :: Image -> Int
outputHeight :: 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 -> BlitM s ()) -> BlitM 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 -> BlitM s ()) -> BlitM s ())
-> (Int -> BlitM s ()) -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ SpanOp -> Int -> BlitM s ()
forall s. SpanOp -> Int -> BlitM s ()
snocOp (Int -> SpanOp
Skip Int
outputWidth')
addMaybeClipped CropRight {Image
croppedImage :: Image -> Image
croppedImage :: Image
croppedImage, Int
outputWidth :: Int
outputWidth :: Image -> Int
outputWidth} = 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
skipColumns
    Int
r <- 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 x :: Int
x = Int
outputWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s
    Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
r) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remainingColumns ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> BlitM s ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
x
    Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClipped CropLeft {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
leftSkip :: Image -> Int
leftSkip :: Int
leftSkip} = do
    (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skipColumns ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> BlitM s ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
leftSkip
    Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClipped CropBottom {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
outputHeight :: Int
outputHeight :: Image -> Int
outputHeight} = 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
    Int
r <- 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
remainingRows
    let x :: Int
x = Int
outputHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s
    Bool -> BlitM s () -> BlitM s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
r) (BlitM s () -> BlitM s ()) -> BlitM s () -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
remainingRows ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> BlitM s ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
x
    Image -> BlitM s ()
forall s. Image -> BlitM s ()
addMaybeClipped Image
croppedImage
addMaybeClipped CropTop {Image
croppedImage :: Image
croppedImage :: Image -> Image
croppedImage, Int
topSkip :: Image -> Int
topSkip :: Int
topSkip} = do
    (Int -> Identity Int) -> BlitState -> Identity BlitState
Lens' BlitState Int
skipRows ((Int -> Identity Int) -> BlitState -> Identity BlitState)
-> Int -> BlitM s ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter s s a a -> a -> m ()
+= Int
topSkip
    Image -> BlitM 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 :: String
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Lens' BlitState Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
addMaybeClippedJoin String
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
$ String -> BlitM s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BlitM s ()) -> String -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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
_ -> String -> BlitM s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BlitM s ()) -> String -> BlitM s ()
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has unhandled skip class"

addUnclippedText :: Attr -> DisplayText -> BlitM s ()
addUnclippedText :: Attr -> DisplayText -> BlitM s ()
addUnclippedText Attr
a DisplayText
txt = do
    let op :: SpanOp
op = Attr -> Int -> Int -> DisplayText -> 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
$ DisplayText -> Int64
TL.length DisplayText
txt)
                      DisplayText
txt
        usedDisplayColumns :: Int
usedDisplayColumns = DisplayText -> Int
wctlwidth DisplayText
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 (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 :: 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 s. Lens (BlitEnv s) (BlitEnv s) (MRowOps s) (MRowOps s)
mrowOps
    SpanOps
rowOps <- StateT BlitState (ST s) SpanOps
-> ReaderT (BlitEnv s) (StateT BlitState (ST s)) SpanOps
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 (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

-- | snocs the operation to the operations for the given row.
snocOp :: SpanOp -> Int -> BlitM s ()
snocOp :: 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 s. Lens (BlitEnv s) (BlitEnv s) (MRowOps s) (MRowOps 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. Lens' (BlitEnv s) DisplayRegion
region
    StateT BlitState (ST s) () -> BlitM s ()
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 (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
$ String -> ST s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"row " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
row String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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'