-- | 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.Maybe (fromMaybe, listToMaybe)
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.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.Break
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 breakPoint = do
    -- TODO: Trim spaces around breaks.
    let (runs1, runs2) = splitTextsAt8 breakPoint runs
    let (nextX, pfs) = mapAccumL addRunH currentX runs1
    let next = nextBreakPoint (fromIntegral breakPoint) runs
    if abs nextX <= maxWidth
        then (pfs, runs2)
        else tryAddSplitRunsH maxWidth currentX runs (fromIntegral next)

-- | Find the farthermost break point in one of the given runs, whose offset is
-- less than the given limit, respecting locale rules.
--
-- The result will be an offset in `Word8` units from the start of the first
-- `Run` from the list.
--
-- If no breaks are possible, the result will be @0@.
nextBreakPoint :: Int -> [WithSpan Run] -> Int
nextBreakPoint _ [] = 0
nextBreakPoint limit runs@(headRun:_) = fromMaybe 0 $ listToMaybe points
    where
        -- TODO: Try to limit deconstruction of texts for offsets.
        (Text _ firstRunOffset _) = getText headRun
        points =
            dropWhile (>= limit) $ breakPoints firstRunOffset $ reverse runs

breakPoints :: Int -> [WithSpan Run] -> [Int]
breakPoints _ [] = []
breakPoints firstRunOffset (x:xs) = offsets ++ rest
    where
        -- TODO: Try to limit deconstruction of texts for offsets.
        (Text _ thisRunOffset _) = getText x
        offsets = map (correctOffset . fst) (runLineBreaks x)
        correctOffset = (+ (thisRunOffset - firstRunOffset))
        rest = breakPoints firstRunOffset xs

-- | 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 p@(Paragraph arr off spans opts) = do
    let (end, texts) = cuts arr off spans
    let indexes = [0..]
    let paragraphStart = fromIntegral off

    (s, t, i) <- zip3 spans texts indexes
    let lang = spanLanguage s
    let breaks = paragraphLineBreaks p end lang
    -- TODO: Try to limit deconstruction of texts for offsets.
    let (Text _ spanStart _) = t
    return RS.ResolvedSpan
        { RS.spanIndex = i
        , RS.spanText = t
        , RS.spanFont = paragraphFont opts
        , RS.spanLineHeight = paragraphLineHeight opts
        , RS.spanLanguage = lang
        , RS.spanLineBreaks = subOffsetsDesc (spanStart - paragraphStart) breaks
        }

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

runLineBreaks :: WithSpan Run -> [(Int, BreakStatus.Line)]
runLineBreaks (WithSpan rs run) = dropWhile (not . valid) $
    subOffsetsDesc (runStart - spanStart) $ RS.spanLineBreaks rs
    where
        valid (off, _) = off < runLength
        runLength = lengthWord8 $ getText run
        -- TODO: Try to limit deconstruction of texts for offsets.
        (Text _ runStart _) = getText run
        (Text _ spanStart _) = getText rs

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

-- | Given an underlying `Array`, an initial offset, and a list of consecutive
-- `Span`s, produce a list of `Text`s corresponding to the given spans, as well
-- as the offset of the end of the last `Text`.
--
-- TODO: Consider adding checks for array bounds.
cuts :: Array -> I8 -> [Span] -> (I8, [Text])
cuts arr initialOffset spans = 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)