module Data.Text.ParagraphLayout.Internal.Plain
    (Paragraph(..)
    ,ParagraphLayout(..)
    ,ParagraphOptions(..)
    ,SpanLayout(..)
    ,layoutPlain
    )
where

import Control.Applicative (ZipList(ZipList), getZipList)
import Data.Int (Int32)
import Data.List (mapAccumL)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
import Data.Text.Foreign (lengthWord8)
import Data.Text.Glyphize
    (Buffer(..)
    ,ContentType(ContentTypeUnicode)
    ,Direction(..)
    ,FontExtents(..)
    ,GlyphInfo
    ,GlyphPos(x_advance)
    ,defaultBuffer
    ,fontExtentsForDir
    ,shape
    )
import Data.Text.ICU (LocaleName(Locale), breakLine)
import qualified Data.Text.ICU as BreakStatus (Line)
import Data.Text.Internal (Text(Text))
import qualified Data.Text.Lazy as Lazy

import Data.Text.ParagraphLayout.Internal.Break
import Data.Text.ParagraphLayout.Internal.Fragment
import Data.Text.ParagraphLayout.Internal.LineHeight
import Data.Text.ParagraphLayout.Internal.Paragraph
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 = layoutAndAlignLines maxWidth $ 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 -> [WithSpan Run] -> [WithSpan Fragment]
layoutAndAlignLines maxWidth runs = frags
    where
        frags = concat fragsInLines
        (_, fragsInLines) = mapAccumL positionLineH originY canonicalLines
        canonicalLines = map canonicalOrder logicalLines
        logicalLines = layoutLines maxWidth runs
        originY = paragraphOriginY

-- | Reorder the given fragments from logical order to whatever order HarfBuzz
-- uses (LTR for horizontal text, TTB for vertical text), so that cluster order
-- is preserved even across runs.
canonicalOrder :: [WithSpan PF.ProtoFragment] -> [WithSpan PF.ProtoFragment]
canonicalOrder [] = []
canonicalOrder pfs@((WithSpan _ headPF):_) = case PF.direction headPF of
    -- TODO: Update for bidi.
    Just DirLTR -> pfs
    Just DirRTL -> reverse pfs
    Just DirTTB -> pfs
    Just DirBTT -> reverse pfs
    -- If no guess can be made, use LTR.
    -- TODO: Add explicit direction to input interface.
    Nothing -> 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 -> [WithSpan Run] -> [[WithSpan PF.ProtoFragment]]
layoutLines maxWidth runs
    | null rest
        -- Everything fits. We are done.
        = fitting : []
    | null fitting
        -- Nothing fits. We must resolve this by overflowing.
        = overflowing : []
    | otherwise
        -- Something fits, the rest goes on the next line.
        = fitting : layoutLines maxWidth rest
    where
        (fitting, rest) = layoutAndWrapRunsH maxWidth runs
        overflowing = layoutRunsH 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 -> [WithSpan PF.ProtoFragment] ->
    (Int32, [WithSpan Fragment])
positionLineH originY pfs = (nextY, frags)
    where
        nextY = maximum $ map y_min rects
        rects = map (\(WithSpan _ r) -> fragmentRect r) frags
        frags = snd $ 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 -> [WithSpan Run] ->
    ([WithSpan PF.ProtoFragment], [WithSpan Run])
layoutAndWrapRunsH maxWidth runs =
    fromMaybe lastResortSplit $ listToMaybe validSplits
    where
        lastResortSplit = do
            let (runs1, runs2) = splitTextsAt8 1 runs
            let pfs = layoutRunsH runs1
            (pfs, runs2)
        applySplit (runs1, runs2) = do
            let pfs = layoutRunsH runs1
            if totalAdvances pfs <= maxWidth
                then Just (pfs, runs2)
                else Nothing
        validSplits = catMaybes $ map applySplit splits
        splits = noSplit : (filter hasContent $ breakSplits [] (reverse runs))
        noSplit = (runs, [])
        hasContent = not . null . fst

-- | 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

-- | Recursive function for finding all possible ways to split a list of runs
-- into two on a valid line-breaking boundary, including the start of the first
-- run and excluding the end of the last run.
--
-- The first input list is the suffix consisting of runs that have already been
-- considered for breaking. These will be appended to the output suffix as they
-- are.
--
-- The second input list is the prefix consisting of runs to be considered for
-- breaking, in reverse order.
--
-- The results in the form (prefix, suffix) will be ordered from the longest
-- prefix to shortest.
breakSplits :: [WithSpan Run] -> [WithSpan Run] ->
    [([WithSpan Run], [WithSpan Run])]
breakSplits _ [] = []
breakSplits closed (x:xs) = splits ++ breakSplits (x:closed) xs
    where
        splits = map mapFunc $ runLineSplits x
        mapFunc ((x1, x2), _) =
            (reverse $ collapse $ x1 :| xs, collapse $ x2 :| closed)

-- | 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.ProtoFragment dir totalX glyphs
        glyphs = shapeRun (WithSpan rs run)
        positions = map snd glyphs
        totalX = sum $ map x_advance positions
        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
        -- TODO: Set beginsText / endsText.
        buffer = defaultBuffer
            { text = Lazy.fromStrict $ runText run
            , contentType = Just ContentTypeUnicode
            , direction = runDirection run
            , script = runScript run
            , language = Just $ RS.spanLanguage rs
            }
        features = []

resolveSpans :: Paragraph -> [RS.ResolvedSpan]
resolveSpans p@(Paragraph arr pStart spans pOpts) = do
    let sBounds = paragraphSpanBounds p
    let pEnd = NonEmpty.last sBounds
    let sStarts = NonEmpty.init sBounds
    let sLengths = map spanLength spans

    (i, s, sStart, sLen) <- getZipList $ (,,,)
        <$> ZipList [0..]
        <*> ZipList spans
        <*> ZipList sStarts
        <*> ZipList sLengths
    let lang = spanLanguage $ spanOptions s
    let breaks = paragraphLineBreaks p pEnd lang
    return RS.ResolvedSpan
        { RS.spanIndex = i
        , RS.spanOffsetInParagraph = sStart - pStart
        -- TODO: Consider adding checks for array bounds.
        , RS.spanText = Text arr sStart sLen
        , RS.spanFont = paragraphFont pOpts
        , RS.spanLineHeight = paragraphLineHeight pOpts
        , RS.spanLanguage = lang
        , RS.spanLineBreaks = subOffsetsDesc (sStart - pStart) breaks
        }

paragraphLineBreaks :: Paragraph -> Int -> String -> [(Int, BreakStatus.Line)]
paragraphLineBreaks (Paragraph arr off _ _) end lang =
    breaksDesc (breakLine (localeFromLanguage lang)) paragraphText
    where
        paragraphText = Text arr off (end - off)

-- | Split the given run at every valid line break position.
runLineSplits :: WithSpan Run ->
    [((WithSpan Run, WithSpan Run), BreakStatus.Line)]
runLineSplits r = map split $ runLineBreaks r
    where
        split (i, status) = (splitTextAt8 i r, status)

runLineBreaks :: WithSpan Run -> [(Int, BreakStatus.Line)]
runLineBreaks (WithSpan rs run) = dropWhile (not . valid) $
    subOffsetsDesc (runOffsetInSpan run) $ RS.spanLineBreaks rs
    where
        valid (off, _) = off < runLength
        runLength = lengthWord8 $ getText run

-- TODO: Identify and correct for differences between the two.
localeFromLanguage :: String -> LocaleName
localeFromLanguage x = Locale x