module Data.Text.ParagraphLayout (Span(..), layout)
where

import Data.Text.Glyphize
    (Buffer(..)
    ,ContentType(ContentTypeUnicode)
    ,Direction(..)
    ,Font
    ,GlyphInfo
    ,GlyphPos
    ,defaultBuffer
    ,shape
    )
import qualified Data.Text.ICU.Char as ICUChar
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as Text
import Data.Text.Script (charScript)

type ScriptCode = String
type Language = String

-- Paragraph is broken into spans by the caller.
--
-- Each span could have a different font family, size, style, text decoration,
-- colour, language, etc.
--
-- TODO: Add all relevant attributes.
--
data Span = Span
    { spanText :: Text
    , spanFont :: Font
    , spanLanguage :: Maybe Language
    }
    deriving (Eq, Show)

-- Each span can be broken into one or more runs by Balkón.
--
-- Each run could have a different script, language, or direction.
--
data Run = Run
    { runText :: Text
    , runDirection :: Maybe Direction
    , runScript :: Maybe ScriptCode
    , runOriginalSpan :: Span
    }
    deriving (Eq, Show)

type ProtoRun = (String, Maybe Direction, ScriptCode)

data Merged a = Incompatible | Merged a

data Position = Beginning | Middle | End | Only
    deriving (Eq)

-- TODO: Add maximum line length as input.
-- TODO: Compute and return bounding box for each provided span.
--       More if implementing the CSS Box Model.
-- TODO: Also compute and return overall bounding box, in addition to individual
--       ones.
-- TODO: Allow a run across multiple spans (e.g. if they only differ by colour).
layout :: [Span] -> [[(GlyphInfo, GlyphPos)]]
layout = layoutRuns . concat . map spanToRuns

-- TODO: Optimise and preserve the Data.Text.Lazy structure.
spanToRuns :: Span -> [Run]
spanToRuns s = map run $ protoRuns chars
    where
        chars = reverse $ Text.unpack $ spanText s
        run (t, d, sc) = Run
            { runText = Text.pack t
            , runDirection = d
            , runScript = Just sc
            , runOriginalSpan = s
            }

-- TODO: Try to avoid reversing.
protoRuns :: [Char] -> [ProtoRun]
protoRuns = reverse . map (\(t, d, s) -> (reverse t, d, s)) . foldr foldRun []

foldRun :: Char -> [ProtoRun] -> [ProtoRun]
foldRun c [] =
    -- If there are no runs, create a new run with a single character.
    [([c], charDirection c, charScript c)]
foldRun c (r@(oldString, d1, s1):rs) =
    case (mergeDirections d1 d2, mergeScripts s1 s2) of
        -- If direction & script are compatible, add to existing run.
        (Merged d, Merged s) -> ((c:oldString, d, s):rs)
        -- Otherwise create a new run.
        _ -> (([c], d2, s2):r:rs)
    where
        d2 = charDirection c
        s2 = charScript c

-- Simplified detection of text direction for unidirectional text.
mergeDirections :: Maybe Direction -> Maybe Direction -> Merged (Maybe Direction)
mergeDirections Nothing Nothing = Merged Nothing
mergeDirections (Just d1) Nothing = Merged (Just d1)
mergeDirections Nothing (Just d2) = Merged (Just d2)
mergeDirections (Just d1) (Just d2)
    | d1 == d2 = Merged (Just d1)
    | otherwise = Incompatible

-- TODO: Implement proper inheritance rules.
mergeScripts :: ScriptCode -> ScriptCode -> Merged ScriptCode
mergeScripts "Zyyy" s2 = Merged s2
mergeScripts s1 "Zyyy" = Merged s1
mergeScripts s1 "Zinh" = Merged s1
mergeScripts s1 s2
    | s1 == s2 = Merged s1
    | otherwise = Incompatible

-- TODO: Use the BiDi algorithm to support bidirectional text.
charDirection :: Char -> Maybe Direction
charDirection c = case ICUChar.direction c of
    ICUChar.LeftToRight -> Just DirLTR
    ICUChar.RightToLeft -> Just DirRTL
    ICUChar.RightToLeftArabic -> Just DirRTL
    _ -> Nothing

layoutRuns :: [Run] -> [[(GlyphInfo, GlyphPos)]]
layoutRuns [] = []
layoutRuns [s] = [layoutOneRun Only s]
-- TODO: What if there are no visible characters in the edge runs?
layoutRuns (s1:s2:ss) = (layoutOneRun Beginning s1):(layoutRemainingRuns s2 ss)

layoutRemainingRuns :: Run -> [Run] -> [[(GlyphInfo, GlyphPos)]]
layoutRemainingRuns s [] = [layoutOneRun End s]
layoutRemainingRuns s1 (s2:ss) = (layoutOneRun Middle s1):(layoutRemainingRuns s2 ss)

layoutOneRun :: Position -> Run -> [(GlyphInfo, GlyphPos)]
layoutOneRun pos run = shape font buffer features
    where
        originalSpan = runOriginalSpan run
        font = spanFont originalSpan
        lang = spanLanguage originalSpan
        buffer = defaultBuffer { text = runText run
                        , contentType = Just ContentTypeUnicode
                        , direction = runDirection run
                        , script = runScript run
                        , language = lang
                        , beginsText = pos == Beginning || pos == Only
                        , endsText = pos == End || pos == Only
                        }
        features = []