-- | Shaping for a paragraph of plain, unidirectional text using a single font.
--
-- The input text must be encoded as UTF-8 in a contiguous byte array.
--
-- Positions and distances are represented as 32-bit integers. Their unit must
-- be defined by the caller, who must calculate the desired dimensions of the
-- EM square of the input font and set them using @hb_font_set_scale()@. For
-- example, if @1em = 20px@, if the output pixels are square, and if the output
-- coordinates are in 1/64ths of a pixel, you should set both the @x_scale@ and
-- the @y_scale@ to @1280@.
module Data.Text.ParagraphLayout.Plain
    (LineHeight(..)
    ,Paragraph(..)
    ,ParagraphLayout(..)
    ,ParagraphOptions(..)
    ,Rect(..)
    ,Span(..)
    ,SpanLayout(..)
    ,layoutPlain
    )
where

import Data.Int (Int32)
import Data.List (mapAccumL)
import Data.Text.Array (Array)
import Data.Text.Foreign (I8, lengthWord8)
import Data.Text.Glyphize
    (Buffer(..)
    ,ContentType(ContentTypeUnicode)
    ,Font
    ,FontExtents(..)
    ,GlyphInfo
    ,GlyphPos(x_advance)
    ,defaultBuffer
    ,fontExtentsForDir
    ,shape
    )
import Data.Text.Internal (Text(Text))
import qualified Data.Text.Lazy as Lazy

import Data.Text.ParagraphLayout.Fragment
import Data.Text.ParagraphLayout.LineHeight
import qualified Data.Text.ParagraphLayout.ProtoFragment as PF
import Data.Text.ParagraphLayout.Rect
import qualified Data.Text.ParagraphLayout.ResolvedSpan as RS
import Data.Text.ParagraphLayout.Run
import Data.Text.ParagraphLayout.Span
import Data.Text.ParagraphLayout.TextContainer

-- | Text to be laid out as a paragraph.
--
-- May be divided into any number of neighbouring spans, each of which will
-- have its own layout rectangle(s) calculated.
data Paragraph = Paragraph

    Array
    -- ^ A byte array containing the whole text to be laid out, in UTF-8.

    I8
    -- ^ Byte offset of the first span.
    -- Any characters preceding this offset will not be shaped, but may still
    -- be used to influence the shape of neighbouring characters.

    [Span]
    -- ^ Parts of the text to be laid out, in logical order.
    -- The offset plus total length of all spans must not exceed array bounds.
    -- Any characters following the last span will not be shaped, but may still
    -- be used to influence the shape of neighbouring characters.

    ParagraphOptions
    -- ^ Properties applying to the paragraph as a whole.

data ParagraphOptions = ParagraphOptions
    { paragraphFont :: Font
    , paragraphLineHeight :: LineHeight
    , paragraphMaxWidth :: Int32
    }

-- | The resulting layout of the whole paragraph.
data ParagraphLayout = ParagraphLayout
    { paragraphRect :: Rect Int32
    -- ^ The containing block (CSS3).
    , spanLayouts :: [SpanLayout]
    }
    deriving (Eq, Read, Show)

-- | The resulting layout of each span, which may include multiple fragments if
-- broken over multiple lines.
data SpanLayout = SpanLayout [Fragment]
    deriving (Eq, Read, Show)

-- | Wrapper for temporarily mapping the relationship to a `Span`.
data WithSpan a = WithSpan RS.ResolvedSpan a

instance Functor WithSpan where
    fmap f (WithSpan s a) = WithSpan s (f a)

instance TextContainer a => TextContainer (WithSpan a) where
    getText (WithSpan _ c) = getText c
    setText t (WithSpan rs c) = WithSpan rs (setText t c)

splitBySpanIndex :: [WithSpan a] -> [[a]]
splitBySpanIndex xs = [getBySpanIndex i xs | i <- [0..]]

getBySpanIndex :: Int -> [WithSpan a] -> [a]
getBySpanIndex idx xs = map contents $ filter matchingIndex $ xs
    where
        matchingIndex (WithSpan rs _) = (RS.spanIndex rs) == idx
        contents (WithSpan _ x) = x

spanRects :: SpanLayout -> [Rect Int32]
spanRects (SpanLayout frags) = map fragmentRect frags

base :: (Num a) => Rect a
base = Rect 0 0 0 0

containRects :: (Ord a, Num a) => [Rect a] -> Rect a
containRects = foldr union base

-- | Interface for basic plain text layout.
--
-- The entire paragraph will be assumed to have the same text direction and
-- will be shaped using a single font, starting from the left for LTR text or
-- from the right for RTL text.
layoutPlain :: Paragraph -> ParagraphLayout
layoutPlain p@(Paragraph _ _ _ opts) = ParagraphLayout pRect sls
    where
        pRect = containRects $ concat $ map spanRects sls
        sls = map SpanLayout fragsBySpan
        fragsBySpan = take (length spans) $ 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 alignLineH originY protoFragsInLines
        protoFragsInLines = layoutLines maxWidth runs
        originY = 0

-- | 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) = tryAddRunsH maxWidth originX runs
        overflowing = addRunsH originX runs
        originX = 0

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

-- | Align all the given horizontal fragments vertically 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.
alignLineH :: Int32 -> [WithSpan PF.ProtoFragment] ->
    (Int32, [WithSpan Fragment])
alignLineH originY pfs = (nextY, frags)
    where
        nextY = maximum $ map y_min rects
        rects = map (\(WithSpan _ r) -> fragmentRect r) frags
        frags = map (alignFragmentH originY) pfs

-- | Align the given horizontal fragment vertically on a line,
-- using `originY` as its top edge.
alignFragmentH :: Int32 -> WithSpan PF.ProtoFragment -> WithSpan Fragment
alignFragmentH originY (WithSpan rs pf) =
    WithSpan rs (Fragment rect (penX, penY) (PF.glyphs pf))
    where
        rect = Rect (PF.offset pf) 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

-- | Like `addRunsH`, but break the input runs as necessary to prevent
-- overflowing the maximum line width,
-- and return the remaining runs to be placed on other lines.
tryAddRunsH :: Int32 -> Int32 -> [WithSpan Run] ->
    ([WithSpan PF.ProtoFragment], [WithSpan Run])
tryAddRunsH maxWidth currentX runs =
    tryAddSplitRunsH maxWidth currentX runs totalLength
    where
        totalLength = fromIntegral $ sum $ map (lengthWord8 . getText) runs

-- | Like `addRunsH`, but break the input runs at the given position, or closer
-- to the start if necessary to prevent overflowing the maximum line width,
-- and return the remaining runs to be placed on other lines.
tryAddSplitRunsH :: Int32 -> Int32 -> [WithSpan Run] -> I8 ->
    ([WithSpan PF.ProtoFragment], [WithSpan Run])
tryAddSplitRunsH _ _ [] _ = ([], [])
tryAddSplitRunsH _ currentX runs 0 = do
    -- Last resort splitting by character.
    -- TODO: Split by glyph instead.
    -- Note: The following auto-adjusts to UTF-8 code point boundary.
    let (runs1, runs2) = splitTextsAt8 1 runs
    let (_, pfs) = mapAccumL addRunH currentX runs1
    (pfs, runs2)
tryAddSplitRunsH maxWidth currentX runs splitPoint = do
    let (runs1, runs2) = splitTextsAt8 splitPoint runs
    let (nextX, pfs) = mapAccumL addRunH currentX runs1
    if abs nextX <= maxWidth
        then (pfs, runs2)
        -- TODO: Use ICU breaking library.
        else tryAddSplitRunsH maxWidth currentX runs (splitPoint-1)

-- | Calculate layout for multiple runs on the same line and
-- arrange them in one horizontal direction starting from the given x_offset.
addRunsH :: Int32 -> [WithSpan Run] -> [WithSpan PF.ProtoFragment]
addRunsH currentX runs = snd $ mapAccumL addRunH currentX runs

-- | Calculate layout for the given run,
-- place the generated fragment horizontally at the given x_offset in a line,
-- and return the final x_offset for continuation.
addRunH :: Int32 -> WithSpan Run -> (Int32, WithSpan PF.ProtoFragment)
addRunH currentX run = (nextX, WithSpan rs pf)
    where
        WithSpan rs pf = layoutRun currentX run
        nextX = currentX + PF.advance pf

-- | Calculate layout for the given run and position it in a line.
layoutRun :: Int32 -> WithSpan Run -> WithSpan PF.ProtoFragment
layoutRun originX (WithSpan rs run) = WithSpan rs pf
    where
        pf = PF.ProtoFragment dir originX 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 (Paragraph arr off spans opts) = do
    let texts = cuts arr off spans
    let indexes = [0..]
    (s, t, i) <- zip3 spans texts indexes
    return RS.ResolvedSpan
        { RS.spanIndex = i
        , RS.spanText = t
        , RS.spanFont = paragraphFont opts
        , RS.spanLineHeight = paragraphLineHeight opts
        , RS.spanLanguage = spanLanguage s
        }

-- | Produce a list of `Text`s, defined by an initial offset and a list of
-- consecutive `Span`s, out of the underlying `Array`.
--
-- TODO: Consider adding checks for array bounds.
cuts :: Array -> I8 -> [Span] -> [Text]
cuts arr initialOffset spans = snd $ mapAccumL (cut arr) initialOffset spans

-- | Produce a `Text`, defined by an initial offset and a `Span`, out of the
-- underlying `Array`.
cut :: Array -> I8 -> Span -> (I8, Text)
cut arr off s = (end, t)
    where
        len = spanLength s
        end = off + len
        t = Text arr (fromIntegral off) (fromIntegral len)