Layout.hs

-- | Implementation of paragraph layout, decoupled from external interfaces.
module Data.Text.ParagraphLayout.Internal.Layout
    ( FragmentWithSpan
    , layoutAndAlignLines
    )
where

import Data.Foldable (toList)
import Data.Int (Int32)
import Data.List (mapAccumL)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, (<|))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Semigroup (sconcat)
import Data.Text.Foreign (lengthWord8)
import Data.Text.Glyphize
    ( Buffer (..)
    , ContentType (ContentTypeUnicode)
    , Direction (DirLTR, DirRTL, DirTTB, DirBTT)
    , GlyphInfo
    , GlyphPos
    , defaultBuffer
    , shape
    )
import qualified Data.Text.ICU as BreakStatus (Line (Hard))
import qualified Data.Text.Lazy as Lazy

import Data.Text.ParagraphLayout.Internal.AncestorBox
import Data.Text.ParagraphLayout.Internal.ApplyBoxes
import Data.Text.ParagraphLayout.Internal.BiDiReorder
import Data.Text.ParagraphLayout.Internal.BoxOptions
import Data.Text.ParagraphLayout.Internal.Break
import Data.Text.ParagraphLayout.Internal.Fragment
import Data.Text.ParagraphLayout.Internal.Line
import Data.Text.ParagraphLayout.Internal.ParagraphAlignment
import Data.Text.ParagraphLayout.Internal.ParagraphExtents
import qualified Data.Text.ParagraphLayout.Internal.ProtoFragment as PF
import qualified Data.Text.ParagraphLayout.Internal.ProtoLine as PL
import Data.Text.ParagraphLayout.Internal.Rect
import qualified Data.Text.ParagraphLayout.Internal.ResolvedBox as RB
import qualified Data.Text.ParagraphLayout.Internal.ResolvedSpan as RS
import Data.Text.ParagraphLayout.Internal.Run
import Data.Text.ParagraphLayout.Internal.SplitList
import Data.Text.ParagraphLayout.Internal.TextContainer
import Data.Text.ParagraphLayout.Internal.TextOptions
import qualified Data.Text.ParagraphLayout.Internal.VerticalOffsets as VO
import Data.Text.ParagraphLayout.Internal.WithSpan

-- This is redundant.
-- TODO: Consider using `ResolvedSpan` as `fragmentUserData`, then swapping it
--       for the actual `spanUserData` before returning it to the user.
type ProtoFragmentWithSpan d = WithSpan d PF.ProtoFragment
type FragmentWithSpan d = WithSpan d (Fragment d)
type ProtoFragmentWithBoxes d = WithBoxes d (ProtoFragmentWithSpan d)

-- | Create a multi-line layout from the given runs, splitting them as
-- necessary to fit within the requested line width.
--
-- The first output component is a flat list of fragments positioned
-- in both dimensions.
--
-- The second output component is a list of lines containing the
-- positioned content.
layoutAndAlignLines
    :: Direction
    -> ParagraphAlignment
    -> Int32
    -> NonEmpty (WithSpan d Run)
    -> ([FragmentWithSpan d], [Line])
layoutAndAlignLines dir align maxWidth runs = (frags, ls)
    where
        frags = concatMap toList fragsInLines
        (fragsInLines, ls) = unzip fragsAndLines
        (_, fragsAndLines) = mapAccumL positionLine originY numberedLines
        positionLine = positionLineH dir align maxWidth
        numberedLines = zip [1 ..] canonicalLines
        canonicalLines = fmap reorderProtoFragments visibleLines
        visibleLines = filter PL.visible logicalLines
        logicalLines = toList $ layoutLines maxWidth [] runs
        originY = paragraphOriginY

reorderProtoFragments :: PL.ProtoLine NonEmpty d -> PL.ProtoLine NonEmpty d
reorderProtoFragments pl@(PL.ProtoLine { PL.protoFragments = pfs }) =
    pl { PL.protoFragments = reorder pfs }

-- | Create a multi-line layout from the given runs, splitting them as
-- necessary to fit within the requested line width.
--
-- The output is a two-dimensional list of fragments positioned along the
-- horizontal axis.
layoutLines :: Int32 -> [RB.ResolvedBox d] -> NonEmpty (WithSpan d Run) ->
    NonEmpty (PL.ProtoLine NonEmpty d)
layoutLines maxWidth openBoxes runs = case nonEmpty rest of
        -- Everything fits. We are done.
        Nothing -> fitting :| []
        -- Something fits, the rest goes on the next line.
        Just runs' -> fitting <| layoutLines maxWidth openBoxes' runs'
    where
        (fitting, rest) = layoutAndWrapRunsH maxWidth openBoxes runs
        -- Update the list of open boxes using the logically last run
        -- on this line.
        openBoxes' = lastSpanBoxes $ PL.protoFragments fitting

-- | Position all the given horizontal fragments on the same line,
-- using @originY@ as its top edge, and return the bottom edge for continuation.
--
-- Also return a `Line` structure with a defined vertical dimensions
-- but undefined horizontal dimensions.
positionLineH
    :: Direction
    -> ParagraphAlignment
    -> Int32
    -> Int32
    -> (Int, PL.ProtoLine NonEmpty d)
    -> (Int32, (NonEmpty (FragmentWithSpan d), Line))
positionLineH dir align maxWidth originY (num, pl) =
    (nextY, (frags, line))
    where
        line = Line { lineNumber = num, lineRect = Rect 0 originY 0 sizeY }
        sizeY = nextY - originY
        (_, frags) = mapAccumL (positionFragmentH num) originX wpfs
        wpfs = PL.applyBoxes alignedLine
        (nextY, alignedLine) = verticalAlignment originY pl
        originX = paragraphOriginX + if lineWidth > maxWidth
            then overflowingLineOffset dir (lineWidth - maxWidth)
            else fittingLineOffset align dir (maxWidth - lineWidth)
        lineWidth = PL.width pl

-- | Update vertical positions of all fragments on the line so that they
-- respect vertical alignment settings and fit on a line whose top coordinate
-- is @originY@. Also returns the bottom coordinate of the line.
verticalAlignment :: Int32 -> PL.ProtoLine NonEmpty d ->
    (Int32, PL.ProtoLine NonEmpty d)
verticalAlignment originY pl = (bottomY, PL.mapFragments setOrigin pl)
    where
        setOrigin rs pf =
            PF.mapVerticalOffsets (VO.alignBaseline (fragOffset rs)) pf

        fragOffset rs = case spanVO rs of
            (Nothing, vo) -> rootOffset + VO.baseline vo
            (Just b, vo) -> case boxVerticalAlignment $ RB.boxOptions b of
                AlignLineTop -> boxTopOffset b + VO.baseline vo
                AlignLineBottom -> boxBottomOffset b + VO.baseline vo
                _ -> error "verticalAlignment: wrong box used as anchor"

        bottomY = originY - finalLineHeight
        finalLineHeight = fittingTop - fittingBottom

        -- Firefox-like behaviour:
        -- First extend the line upwards to fit bottom-aligned boxes,
        -- then extend the line downwards to fit top-aligned boxes.
        fittingTop = maximum $ (:) rootTop $
            map ((rootBottom +) . boxHeight) bottomAlignedBoxes
        fittingBottom = minimum $ (:) rootBottom $
            map ((fittingTop -) . boxHeight) topAlignedBoxes

        rootTop = maximum $ fmap (VO.layoutTop . snd) rootVOs
        rootBottom = minimum $ fmap (VO.layoutBottom . snd) rootVOs
        rootVOs = filter VO.underRoot $ toList allVOs
        rootOffset = originY - fittingTop

        boxHeight b = boxTop b - boxBottom b
        boxTop b = maximum $ map (VO.layoutTop . snd) $ boxVOs b
        boxBottom b = minimum $ map (VO.layoutBottom . snd) $ boxVOs b
        boxVOs b = filter (VO.underBox b) $ toList allVOs
        -- How much to shift from baseline 0 so that layoutTop = originY?
        boxTopOffset b = originY - boxTop b
        -- How much to shift from baseline 0 so that layoutBottom = bottomY?
        boxBottomOffset b = bottomY - boxBottom b

        boxesOnLine = foldr RB.union [] $ fmap fragBoxes $ PL.protoFragments pl
        topAlignedBoxes = filter topAligned boxesOnLine
        bottomAlignedBoxes = filter bottomAligned boxesOnLine
        topAligned rb =
            boxVerticalAlignment (RB.boxOptions rb) == AlignLineTop
        bottomAligned rb =
            boxVerticalAlignment (RB.boxOptions rb) == AlignLineBottom
        fragBoxes (WithSpan rs _) = RS.spanBoxes rs
        -- Struts may get duplicated in `allVOs`.
        -- This should not be a problem since we are using idempotent functions.
        allVOs = sconcat $ fmap fragStruttedVOs $ PL.protoFragments pl
        fragStruttedVOs (WithSpan rs _) = spanStruttedVOs rs
        spanVO rs = NonEmpty.head $ spanStruttedVOs rs
        spanStruttedVOs rs =
            VO.strutted (RS.spanTextOptions rs) (RS.spanBoxes rs)

-- | Inline offset of the first fragment on a line that overflows.
overflowingLineOffset :: Direction -> Int32 -> Int32
overflowingLineOffset DirLTR _ = 0
overflowingLineOffset DirTTB _ = 0
overflowingLineOffset DirRTL excess = -excess
-- TODO: Check if the sign needs to be flipped for vertical text.
overflowingLineOffset DirBTT excess = -excess

-- | Inline offset of the first fragment on a line with extra blank space.
fittingLineOffset :: ParagraphAlignment -> Direction -> Int32 -> Int32
fittingLineOffset AlignLeft _ = leftAlignOffset
fittingLineOffset AlignRight _ = rightAlignOffset
fittingLineOffset AlignCentreH _ = centreAlignOffset
fittingLineOffset AlignStart DirLTR = leftAlignOffset
fittingLineOffset AlignEnd DirLTR = rightAlignOffset
fittingLineOffset AlignStart DirRTL = rightAlignOffset
fittingLineOffset AlignEnd DirRTL = leftAlignOffset
-- For completeness, treat vertical directions as horizontal directions
-- rotated 90° clockwise, thus left becomes top and right becomes bottom.
-- TODO: Verify this when vertical text is implemented.
fittingLineOffset AlignStart DirTTB = leftAlignOffset
fittingLineOffset AlignEnd DirTTB = rightAlignOffset
fittingLineOffset AlignStart DirBTT = rightAlignOffset
fittingLineOffset AlignEnd DirBTT = leftAlignOffset

leftAlignOffset :: Int32 -> Int32
leftAlignOffset _ = 0

rightAlignOffset :: Int32 -> Int32
rightAlignOffset slack = slack

centreAlignOffset :: Int32 -> Int32
centreAlignOffset slack = slack `div` 2

-- | Position the given horizontal fragment on a line, using @originX@ as its
-- left edge, returning the X coordinate of its right edge for continuation.
positionFragmentH :: Int -> Int32 -> ProtoFragmentWithBoxes d ->
    (Int32, FragmentWithSpan d)
positionFragmentH line originX (WithBoxes lbs (WithSpan rs pf) rbs) =
    (nextX, WithSpan rs frag)
    where
        nextX = contentX + contentWidth + rightSpacing
        contentX = originX + leftSpacing
        contentWidth = PF.advance pf
        leftSpacing = totalLeftSpacing bs
        rightSpacing = totalRightSpacing bs
        frag = Fragment
            { fragmentUserData = userData
            , fragmentLine = line
            , fragmentAncestorBoxes = bs
            , fragmentContentRect = contentRect
            , fragmentRect = rect
            , fragmentPen = (penX, penY)
            , fragmentGlyphs = (PF.glyphs pf)
            }
        userData = RS.spanUserData rs
        bs = ancestorBoxes lbs rbs rs
        contentRect = Rect contentX fontTop contentWidth (fontBottom - fontTop)
        rect = Rect contentX layoutTop contentWidth (layoutBottom - layoutTop)
        penX = 0
        penY = baseline - layoutTop
        VO.VerticalOffsets
            { VO.layoutTop = layoutTop
            , VO.fontTop = fontTop
            , VO.baseline = baseline
            , VO.fontBottom = fontBottom
            , VO.layoutBottom = layoutBottom
            } = PF.verticalOffsets pf

ancestorBoxes
    :: [RB.ResolvedBox d]
    -> [RB.ResolvedBox d]
    -> RS.ResolvedSpan d
    -> [AncestorBox d]
ancestorBoxes leftBoxes rightBoxes rs = map ancestorBox $ RS.spanBoxes rs
    where
        ancestorBox b = case RB.boxDirection b of
            DirLTR -> AncestorBox
                { boxUserData = RB.boxUserData b
                , boxLeftEdge = leftEdge b
                , boxRightEdge = rightEdge b
                , boxStartEdge = leftEdge b
                , boxEndEdge = rightEdge b
                }
            DirRTL -> AncestorBox
                { boxUserData = RB.boxUserData b
                , boxLeftEdge = leftEdge b
                , boxRightEdge = rightEdge b
                , boxStartEdge = rightEdge b
                , boxEndEdge = leftEdge b
                }
            _ -> AncestorBox
                { boxUserData = RB.boxUserData b
                , boxLeftEdge = NoEdge
                , boxRightEdge = NoEdge
                , boxStartEdge = NoEdge
                , boxEndEdge = NoEdge
                }
        leftEdge b = if b `elem` leftBoxes
            then SpacedEdge $ RB.boxLeftSpacing b
            else NoEdge
        rightEdge b = if b `elem` rightBoxes
            then SpacedEdge $ RB.boxRightSpacing b
            else NoEdge

-- | Calculate layout for multiple horizontal runs, breaking them as necessary
-- to fit as much content as possible without exceeding the maximum line width,
-- and return the remaining runs to be placed on other lines.
layoutAndWrapRunsH
    :: Int32
    -> [RB.ResolvedBox d]
    -> NonEmpty (WithSpan d Run)
    -> (PL.ProtoLine NonEmpty d, [WithSpan d Run])
layoutAndWrapRunsH maxWidth prevOpenBoxes runs = NonEmpty.head $ validProtoLines
    where
        validProtoLines = dropWhile1 tooLong layouts
        tooLong (pl, _) = PL.width pl > maxWidth
        layouts = fmap fstToProtoLine splits
        fstToProtoLine (runs1, runs2) =
            (protoLine prevOpenBoxes (layoutRunsH runs1) runs2, runs2)
        -- TODO: Consider optimising.
        --       We do not need to look for soft breaks further than the
        --       shortest hard break.
        -- TODO: Untrimmed whitespace should be reset to paragraph BiDi level
        --       per rule L1.
        splits = hardSplit runs :| softSplits runs

-- | Construct a `PL.ProtoLine`, peeking at the text run on the following line
-- to determine `PL.nextOpenBoxes`.
protoLine
    :: [RB.ResolvedBox d]
    -> NonEmpty (ProtoFragmentWithSpan d)
    -> [WithSpan d Run]
    -> PL.ProtoLine NonEmpty d
protoLine prev pfs rest = PL.ProtoLine pfs prev next
    where
        next = [] `fromMaybe` firstSpanBoxes rest

firstSpanBoxes :: [WithSpan d a] -> Maybe [RB.ResolvedBox d]
firstSpanBoxes xs = case xs of
    [] -> Nothing
    (WithSpan rs _) : _ -> Just $ RS.spanBoxes rs

lastSpanBoxes :: NonEmpty (WithSpan d a) -> [RB.ResolvedBox d]
lastSpanBoxes xs = case NonEmpty.last xs of
    WithSpan rs _ -> RS.spanBoxes rs

-- | Treat a list of runs as a contiguous sequence, and split them into two
-- lists so that the first list contains as many non-whitespace characters as
-- possible without crossing a hard line break (typically after a newline
-- character).
--
-- If the input is non-empty and starts with a hard line break, then the first
-- output list will contain a run of zero characters. This can be used to
-- correctly size an empty line.
--
-- If there is a hard line break in the input, the run containing it will have
-- its `runHardBreak` set to `True`.
--
-- If there is no hard line break in the input, the first output list will
-- contain the whole input, and the second output list will be empty.
hardSplit :: NonEmpty (WithSpan d Run) ->
    (NonEmpty (WithSpan d Run), [WithSpan d Run])
hardSplit runs = case reverse hSplits of
    [] -> noSplit
    (splitRuns : _) -> forcedSplit splitRuns
    where
        noSplit = (trim runs, [])
        forcedSplit (runs1, runs2) = (markHard $ trim runs1, runs2)
        markHard = mapLast markHard'
        markHard' (WithSpan rs x) = WithSpan rs x { runHardBreak = True }
        trim
            = dropWhileStartCascade isStartSpace
            . dropWhileEndCascade isEndSpace
            . dropWhileEndCascade isNewline
        -- TODO: Consider optimising.
        --       We do not need to look for any line breaks further than the
        --       shortest hard break.
        hSplits = nonEmptyFsts $
            -- from longest to shortest
            splitTextsBy (map fst . filter isHard . runLineBreaks) runs
        isHard (_, status) = status == BreakStatus.Hard

-- | Apply a function to the last element of the non-empty list.
mapLast :: (a -> a) -> NonEmpty a -> NonEmpty a
mapLast f xs = case NonEmpty.uncons xs of
    (x, Nothing) -> f x :| []
    (x, Just rest) -> NonEmpty.cons x $ mapLast f rest

-- | Treat a list of runs as a contiguous sequence,
-- and find all possible ways to split them into two non-empty lists,
-- using soft line break opportunities (typically after words) and then
-- using character boundaries.
--
-- Runs of zero characters will not be created. If line breaking would result
-- in a line that consists entirely of whitespace, this whitespace will be
-- skipped, so an empty line is not created.
--
-- The results in the form (prefix, suffix) will be ordered so that items
-- closer to the start of the list are preferred for line breaking, but without
-- considering overflows.
softSplits :: NonEmpty (WithSpan d Run) ->
    [(NonEmpty (WithSpan d Run), [WithSpan d Run])]
softSplits runs = map (allowSndEmpty . trimFst) splits
    where
        trimFst (runs1, runs2) = (trim runs1, runs2)
        trim
            = dropWhileStartCascade isStartSpace
            . dropWhileEndCascade isEndSpace
        splits = lSplits ++ cSplits
        lSplits = nonEmptyPairs $
            splitTextsBy (map fst . runLineBreaks) runs
        -- TODO: Consider optimising.
        --       We do not need to look for character breaks further than the
        --       shortest line break.
        cSplits = nonEmptyPairs $
            splitTextsBy (map fst . runCharacterBreaks) runs

-- | The suffix remaining after removing the longest prefix of the list for
-- which the predicate holds, except always including at least the last element
-- of the original list.
dropWhile1 :: (a -> Bool) -> NonEmpty a -> NonEmpty a
dropWhile1 p list = case NonEmpty.uncons list of
    (_, Nothing) -> list
    (x, Just xs) -> if p x
        then dropWhile1 p xs
        else list

-- | Calculate layout for multiple horizontal runs on the same line, without
-- any breaking.
layoutRunsH :: Functor f => f (WithSpan d Run) -> f (ProtoFragmentWithSpan d)
layoutRunsH runs = fmap layoutRunH runs

-- | Calculate layout for the given horizontal run and attach extra information.
layoutRunH :: WithSpan d Run -> ProtoFragmentWithSpan d
layoutRunH (WithSpan rs run) = WithSpan rs pf
    where
        pf = PF.protoFragmentH dir lvl vo glyphs hard
        glyphs = shapeRun (WithSpan rs run)
        dir = runDirection run
        lvl = runLevel run
        vo = VO.fromText (RS.spanTextOptions rs)
        hard = runHardBreak run

-- | Calculate layout for the given run independently of its position.
shapeRun :: WithSpan d Run -> [(GlyphInfo, GlyphPos)]
shapeRun (WithSpan rs run) = shape font buffer features
    where
        font = textFont opts
        buffer = defaultBuffer
            { text = Lazy.fromStrict $ runText run
            , contentType = Just ContentTypeUnicode
            , direction = Just $ runDirection run
            , script = runScript run
            , language = Just $ textLanguage opts
            -- Perhaps counter-intuitively, the `beginsText` and `endsText`
            -- flags refer to everything that "Data.Text.Glyphize" can see,
            -- not just the current run.
            --
            -- Since all runs are cut from a single continuous `Text` that
            -- represents the entire paragraph, and "Data.Text.Glyphize" peeks
            -- at the whole underlying byte array, HarfBuzz will be able to see
            -- both the beginning and the end of the paragraph at all times,
            -- so these flags can always be set.
            , beginsText = True
            , endsText = True
            }
        features = []
        opts = RS.spanTextOptions rs

runLineBreaks :: WithSpan d Run -> [(Int, BreakStatus.Line)]
runLineBreaks (WithSpan rs run) =
    runBreaksFromSpan run $ RS.spanLineBreaks rs

runCharacterBreaks :: WithSpan d Run -> [(Int, ())]
runCharacterBreaks (WithSpan rs run) =
    runBreaksFromSpan run $ RS.spanCharacterBreaks rs

-- | Constrain span breaks to a selected run and adjust offsets.
runBreaksFromSpan :: Run -> [(Int, a)] -> [(Int, a)]
runBreaksFromSpan run spanBreaks =
    dropWhile (not . valid) $ subOffsetsDesc (runOffsetInSpan run) spanBreaks
    where
        valid (off, _) = off <= runLength
        runLength = lengthWord8 $ getText run

-- | Predicate for characters that can be potentially removed from the
-- beginning of a line according to the CSS Text Module.
isStartSpace :: Char -> Bool
isStartSpace c = c `elem` [' ', '\t']

-- | Predicate for characters that can be potentially removed from the end of
-- a line according to the CSS Text Module.
isEndSpace :: Char -> Bool
isEndSpace c = c `elem` [' ', '\t', '\x1680']

-- | Predicate for characters that should be removed from the end of a line in
-- the case of a hard line break.
isNewline :: Char -> Bool
isNewline c = c == '\n'