-- | 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 (catMaybes, fromMaybe)
import Data.Text.Foreign (lengthWord8)
import Data.Text.Glyphize
    ( Buffer (..)
    , ContentType (ContentTypeUnicode)
    , Direction (DirLTR, DirRTL)
    , FontExtents (..)
    , GlyphInfo
    , GlyphPos
    , defaultBuffer
    , fontExtentsForDir
    , 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.Break
import Data.Text.ParagraphLayout.Internal.Fragment
import Data.Text.ParagraphLayout.Internal.LineHeight
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.TextContainer
import Data.Text.ParagraphLayout.Internal.TextOptions
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 output is a flat list of fragments positioned in both dimensions.
layoutAndAlignLines :: Int32 -> NonEmpty (WithSpan d Run) ->
    [FragmentWithSpan d]
layoutAndAlignLines maxWidth runs = frags
    where
        frags = concatMap NonEmpty.toList fragsInLines
        (_, fragsInLines) = mapAccumL positionLineH originY numberedLines
        numberedLines = zip [1 ..] canonicalLines
        canonicalLines = fmap reorderProtoFragments logicalLines
        logicalLines = nonEmptyItems $ 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 }

nonEmptyItems :: Foldable t =>
    t (PL.ProtoLine [] d) -> [PL.ProtoLine NonEmpty d]
nonEmptyItems = catMaybes . map PL.nonEmpty . toList

-- | 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 [] 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, if there is one.
        openBoxes' =
            openBoxes `fromMaybe` lastSpanBoxes (PL.protoFragments fitting)

-- TODO: Allow a run across multiple spans (e.g. if they only differ by colour).

-- | Position all the given horizontal fragments on the same line,
-- using @originY@ as its top edge, and return the bottom edge for continuation.
--
-- Glyphs will be aligned by their ascent line, similar to the behaviour of
-- @vertical-align: top@ in CSS.
--
-- TODO: For rich text, allow other types of vertical alignment.
positionLineH :: Int32 -> (Int, PL.ProtoLine NonEmpty d) ->
    (Int32, NonEmpty (FragmentWithSpan d))
positionLineH originY (num, pl) = (nextY, frags)
    where
        nextY = maximum $ fmap y_min rects
        rects = fmap (\ (WithSpan _ r) -> fragmentRect r) frags
        (_, frags) = mapAccumL (positionFragmentH num originY) originX wpfs
        wpfs = PL.applyBoxes pl
        originX = paragraphOriginX

-- | Position the given horizontal fragment on a line,
-- using @originY@ as its top edge and @originX@ as its left edge,
-- returning the X coordinate of its right edge for continuation.
positionFragmentH :: Int -> Int32 -> Int32 -> ProtoFragmentWithBoxes d ->
    (Int32, FragmentWithSpan d)
positionFragmentH line originY 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 userData line bs rect (penX, penY) (PF.glyphs pf)
        userData = RS.spanUserData rs
        bs = ancestorBoxes lbs rbs rs
        rect = Rect contentX originY contentWidth (-lineHeight)
        penX = 0
        penY = descent + leading `div` 2 - lineHeight
        lineHeight = case textLineHeight opts of
            Normal -> normalLineHeight
            Absolute h -> h
        leading = lineHeight - normalLineHeight
        normalLineHeight = ascent + descent
        ascent = ascender extents
        descent = - descender extents
        extents = fontExtentsForDir (textFont opts) (PF.direction pf)
        opts = RS.spanTextOptions rs

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
                , boxLeftSpacing = leftSpacing b
                , boxRightSpacing = rightSpacing b
                , boxStartSpacing = leftSpacing b
                , boxEndSpacing = rightSpacing b
                }
            DirRTL -> AncestorBox
                { boxUserData = RB.boxUserData b
                , boxLeftSpacing = leftSpacing b
                , boxRightSpacing = rightSpacing b
                , boxStartSpacing = rightSpacing b
                , boxEndSpacing = leftSpacing b
                }
            _ -> AncestorBox
                { boxUserData = RB.boxUserData b
                , boxLeftSpacing = Nothing
                , boxRightSpacing = Nothing
                , boxStartSpacing = Nothing
                , boxEndSpacing = Nothing
                }
        leftSpacing b = if b `elem` leftBoxes
            then Just $ RB.boxLeftSpacing b
            else Nothing
        rightSpacing b = if b `elem` rightBoxes
            then Just $ RB.boxRightSpacing b
            else Nothing

-- | 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 [] 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.
        splits = hardSplit runs :| softSplits runs

-- | Construct a `ProtoLine`, peeking at the text run on the following line
-- to determine `nextOpenBoxes`.
protoLine
    :: [RB.ResolvedBox d]
    -> [ProtoFragmentWithSpan d]
    -> [WithSpan d Run]
    -> PL.ProtoLine [] 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 :: [WithSpan d a] -> Maybe [RB.ResolvedBox d]
lastSpanBoxes xs = case reverse xs of
    [] -> Nothing
    (WithSpan rs _) : _ -> Just $ 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 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) -> ([WithSpan d Run], [WithSpan d Run])
hardSplit runs = allowFstEmpty $ trimFst $ NonEmpty.last $ splits
    where
        trimFst (runs1, runs2) = (trim runs1, runs2)
        trim
            = trimTextsStartPreserve isStartSpace
            . trimTextsEndPreserve isEndSpace
            . trimTextsEndPreserve isNewline
        -- TODO: Consider optimising.
        --       We do not need to look for any line breaks further than the
        --       shortest hard break.
        splits = noSplit :| map allowSndEmpty hSplits
        noSplit = (runs, [])
        hSplits = -- from longest to shortest
            splitTextsBy (map fst . filter isHard . runLineBreaks) runs
        isHard (_, status) = status == BreakStatus.Hard

-- | 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) ->
    [([WithSpan d Run], [WithSpan d Run])]
softSplits runs = map (allowSndEmpty . trimFst) splits
    where
        trimFst (runs1, runs2) = (trim runs1, runs2)
        trim = trimTextsStart isStartSpace . trimTextsEnd isEndSpace
        splits = lSplits ++ cSplits
        lSplits = splitTextsBy (map fst . runLineBreaks) runs
        -- TODO: Consider optimising.
        --       We do not need to look for character breaks further than the
        --       shortest line break.
        cSplits = splitTextsBy (map fst . runCharacterBreaks) runs

allowFstEmpty :: (NonEmpty a, b) -> ([a], b)
allowFstEmpty (a, b) = (NonEmpty.toList a, b)

allowSndEmpty :: (a, NonEmpty b) -> (a, [b])
allowSndEmpty (a, b) = (a, NonEmpty.toList b)

-- | 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 :: [WithSpan d Run] -> [ProtoFragmentWithSpan d]
layoutRunsH runs = map 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 glyphs
        glyphs = shapeRun (WithSpan rs run)
        dir = runDirection 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 = 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'