module Data.Text.ParagraphLayout.Internal.Plain (layoutPlain)
where

import Control.Applicative (ZipList (ZipList), getZipList)
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)
import Data.Text (Text)
import Data.Text.Foreign (lengthWord8)
import Data.Text.Glyphize
    ( Buffer (..)
    , ContentType (ContentTypeUnicode)
    , FontExtents (..)
    , GlyphInfo
    , GlyphPos
    , defaultBuffer
    , fontExtentsForDir
    , shape
    )
import Data.Text.ICU (Breaker, LocaleName, breakCharacter, breakLine)
import qualified Data.Text.ICU as BreakStatus (Line (Hard))
import qualified Data.Text.Lazy as Lazy

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.ParagraphOptions
import Data.Text.ParagraphLayout.Internal.Plain.Paragraph
import Data.Text.ParagraphLayout.Internal.Plain.ParagraphLayout
import qualified Data.Text.ParagraphLayout.Internal.ProtoFragment as PF
import Data.Text.ParagraphLayout.Internal.Rect
import Data.Text.ParagraphLayout.Internal.ResolvedSpan (WithSpan (WithSpan))
import qualified Data.Text.ParagraphLayout.Internal.ResolvedSpan as RS
import Data.Text.ParagraphLayout.Internal.Run
import Data.Text.ParagraphLayout.Internal.Span
import Data.Text.ParagraphLayout.Internal.TextContainer

-- | Lay out a paragraph of plain, unidirectional text using a single font.
layoutPlain :: Paragraph -> ParagraphLayout
layoutPlain p@(Paragraph _ _ _ opts) = paragraphLayout sls
    where
        sls = map SpanLayout fragsBySpan
        fragsBySpan = take (length spans) $ RS.splitBySpanIndex frags
        frags = case nonEmpty wrappedRuns of
            Just xs -> layoutAndAlignLines maxWidth xs
            Nothing -> []
        wrappedRuns = spansToRunsWrapped spans
        maxWidth = paragraphMaxWidth opts
        spans = resolveSpans p

-- | Split a number of spans into a flat array of runs and add a wrapper
-- so that each run can be traced back to its originating span.
spansToRunsWrapped :: [RS.ResolvedSpan] -> [WithSpan Run]
spansToRunsWrapped ss = concat $ map spanToRunsWrapped ss

-- | Split a span into runs and add a wrapper
-- so that each run can be traced back to its originating span.
spanToRunsWrapped :: RS.ResolvedSpan -> [WithSpan Run]
spanToRunsWrapped s = map (WithSpan s) (spanToRuns s)

-- | 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 Run) -> [WithSpan Fragment]
layoutAndAlignLines maxWidth runs = frags
    where
        frags = concatMap NonEmpty.toList fragsInLines
        (_, fragsInLines) = mapAccumL positionLineH originY canonicalLines
        canonicalLines = fmap reorder logicalLines
        logicalLines = nonEmptyItems $ layoutLines maxWidth runs
        originY = paragraphOriginY

nonEmptyItems :: Foldable t => t [a] -> [NonEmpty a]
nonEmptyItems = catMaybes . map 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 -> NonEmpty (WithSpan Run) -> NonEmpty [WithSpan PF.ProtoFragment]
layoutLines maxWidth runs = case nonEmpty rest of
        -- Everything fits. We are done.
        Nothing -> NonEmpty.singleton fitting
        -- Something fits, the rest goes on the next line.
        Just rest' -> fitting <| layoutLines maxWidth rest'
    where
        (fitting, rest) = layoutAndWrapRunsH maxWidth runs

-- 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 -> NonEmpty (WithSpan PF.ProtoFragment) ->
    (Int32, NonEmpty (WithSpan Fragment))
positionLineH originY pfs = (nextY, frags)
    where
        nextY = maximum $ fmap y_min rects
        rects = fmap (\ (WithSpan _ r) -> fragmentRect r) frags
        (_, frags) = mapAccumL (positionFragmentH originY) originX pfs
        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 ::
    Int32 -> Int32 -> WithSpan PF.ProtoFragment -> (Int32, WithSpan Fragment)
positionFragmentH originY originX (WithSpan rs pf) = (nextX, WithSpan rs frag)
    where
        nextX = originX + PF.advance pf
        frag = Fragment rect (penX, penY) (PF.glyphs pf)
        rect = Rect originX originY (PF.advance pf) (-lineHeight)
        penX = 0
        penY = descent + leading `div` 2 - lineHeight
        lineHeight = case RS.spanLineHeight rs of
            Normal -> normalLineHeight
            Absolute h -> h
        leading = lineHeight - normalLineHeight
        normalLineHeight = ascent + descent
        ascent = ascender extents
        descent = - descender extents
        extents = fontExtentsForDir font (PF.direction pf)
        font = RS.spanFont rs

-- | 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 -> NonEmpty (WithSpan Run) ->
    ([WithSpan PF.ProtoFragment], [WithSpan Run])
layoutAndWrapRunsH maxWidth runs = NonEmpty.head $ validLayouts
    where
        validLayouts = dropWhile1 tooLong layouts
        tooLong (pfs, _) = totalAdvances pfs > maxWidth
        layouts = fmap layoutFst splits
        layoutFst (runs1, runs2) = (layoutRunsH runs1, runs2)
        -- TODO: Consider optimising.
        --       We do not need to look for soft breaks further than the
        --       shortest hard break.
        splits = hardSplit runs :| softSplits runs

-- | 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 Run) -> ([WithSpan Run], [WithSpan 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 Run) -> [([WithSpan Run], [WithSpan 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 Run] -> [WithSpan PF.ProtoFragment]
layoutRunsH runs = map layoutRunH runs

-- | Sum of all advances within the given fragments.
totalAdvances :: [WithSpan PF.ProtoFragment] -> Int32
totalAdvances pfs = sum $ map (\ (WithSpan _ pf) -> PF.advance pf) pfs

-- | Calculate layout for the given horizontal run and attach extra information.
layoutRunH :: WithSpan Run -> WithSpan PF.ProtoFragment
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 Run -> [(GlyphInfo, GlyphPos)]
shapeRun (WithSpan rs run) = shape font buffer features
    where
        font = RS.spanFont rs
        buffer = defaultBuffer
            { text = Lazy.fromStrict $ runText run
            , contentType = Just ContentTypeUnicode
            , direction = runDirection run
            , script = runScript run
            , language = Just $ RS.spanLanguage rs
            -- 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 = []

resolveSpans :: Paragraph -> [RS.ResolvedSpan]
resolveSpans p@(Paragraph _ pStart spans pOpts) = do
    let sBounds = paragraphSpanBounds p
    let sTexts = paragraphSpanTexts p
    let pText = paragraphText p
    let sStarts = NonEmpty.init sBounds

    (i, s, sStart, sText) <- getZipList $ (,,,)
        <$> ZipList [0 ..]
        <*> ZipList spans
        <*> ZipList sStarts
        <*> ZipList sTexts
    let lang = spanLanguage $ spanOptions s
    let lBreaks = paragraphBreaks breakLine pText lang
    let cBreaks = paragraphBreaks breakCharacter pText lang
    return RS.ResolvedSpan
        { RS.spanIndex = i
        , RS.spanOffsetInParagraph = sStart - pStart
        , RS.spanText = sText
        , RS.spanFont = paragraphFont pOpts
        , RS.spanLineHeight = paragraphLineHeight pOpts
        , RS.spanLanguage = lang
        , RS.spanLineBreaks = subOffsetsDesc (sStart - pStart) lBreaks
        , RS.spanCharacterBreaks = subOffsetsDesc (sStart - pStart) cBreaks
        }

paragraphBreaks :: (LocaleName -> Breaker a) -> Text -> String -> [(Int, a)]
paragraphBreaks breakFunc txt lang =
    breaksDesc (breakFunc (locale lang LBAuto)) txt

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

runCharacterBreaks :: WithSpan 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'