{-# LANGUAGE TupleSections #-}
-- | Sizes inline text & extracts positioned children,
-- wraps Balkón for the actual logic.
module Graphics.Layout.Inline(inlineMinWidth, inlineMin, inlineNatWidth, inlineHeight,
    inlineSize, inlineChildren, layoutSize, layoutChildren, positionChildren,
    fragmentSize, fragmentSize', fragmentPos, FragmentTree(..),
    positionSubtree, subtreeInner) where

import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
                                Fragment(..), ParagraphLayout(..), AncestorBox(..),
                                layoutRich)
import Data.Text.ParagraphLayout.Rect (Rect(..),
                                       width, height, x_max, x_min, y_min, y_max)
import Data.Text.Internal (Text(..))
import qualified Data.Text as Txt
import Data.Char (isSpace)
import Data.Int (Int32)

import Graphics.Layout.Box (PaddedBox, Length, Size(..), CastDouble(..), fromDouble)
import Graphics.Layout.CSS.Font (Font', hbUnit)

-- | Convert from Harfbuzz units to device pixels as a Double
hbScale = (/hbUnit) . fromIntegral
-- | Convert from Harfbuzz units to device pixels as a Double or Length.
c :: CastDouble a => Int32 -> a
c = fromDouble . hbScale

-- | Compute minimum width for some richtext.
inlineMinWidth :: Paragraph a -> Double
inlineMinWidth self = hbScale $ width $ layoutRich' self 0
-- | Compute minimum width & height for some richtext.
inlineMin :: (CastDouble x, CastDouble y) => Paragraph a -> Size x y
inlineMin self = Size (c $ width rect) (c $ height rect)
    where rect = layoutRich' self 0
-- | Compute natural (single-line) width for some richtext.
inlineNatWidth :: Paragraph a -> Double
inlineNatWidth self = hbScale $ width $ layoutRich' self maxBound
-- | Compute height for rich text at given width.
inlineHeight :: Double -> Paragraph a -> Double
inlineHeight width self =
    hbScale $ height $ layoutRich' self $ round (hbUnit * width)

-- | Compute width & height of some richtext at configured width.
inlineSize :: (CastDouble x, CastDouble y) => Paragraph a -> Size x y
inlineSize self = layoutSize $ layoutRich self
-- | Retrieve children out of some richtext,
-- associating given userdata with them.
inlineChildren :: Eq a => Paragraph a -> [FragmentTree a]
inlineChildren self = layoutChildren $ layoutRich self

-- | Retrieve a laid-out paragraph's rect & convert to CatTrap types.
layoutSize :: (CastDouble x, CastDouble y) => ParagraphLayout a -> Size x y
layoutSize self = Size (c $ width r) (c $ height r)
  where r = paragraphRect self
-- | Retrieve a laid-out paragraph's children & associate with given userdata.
layoutChildren :: Eq a => ParagraphLayout a -> [FragmentTree a]
layoutChildren self = reconstructTree self

-- | Layout a paragraph at given width & retrieve resulting rect.
layoutRich' :: Paragraph a -> Int32 -> Rect Int32
layoutRich' (Paragraph a b c d) width =
    paragraphRect $ layoutRich $ Paragraph a b c d { paragraphMaxWidth = width }

-- | Retrieve the rect for a fragment & convert to CatTrap types.
fragmentSize :: (CastDouble x, CastDouble y) =>
        FragmentTree (a, PaddedBox Length Length, c) -> Size x y
fragmentSize self = Size (c $ width r) (c $ height r)
    where r = treeRect self
-- | Compute the unioned rect for a subtree.
treeRect :: (CastDouble m, CastDouble n) =>
        FragmentTree (a, PaddedBox m n, c) -> Rect Int32
treeRect (Branch _ childs) = foldr unionRect (Rect 0 0 0 0) $ map treeRect childs
    where unionRect a b = Rect (x_min a `min` x_min b) (y_min a `min` y_min b)
            ((x_max a `max` x_max b) - (x_min a `min` x_min b))
            ((y_max a `max` y_max b) - (y_min a `min` x_min b))
treeRect (Leaf self) = fragmentRect self

-- | Variant of `fragmentSize` asserting to the typesystem that both fields
-- of the resulting `Size` are of the same type.
fragmentSize' :: CastDouble x => FragmentTree (a, PaddedBox Length Length, c) -> Size x x
fragmentSize' = fragmentSize -- Work around for typesystem.
-- | Retrieve the position of a fragment.
fragmentPos :: (Double, Double) -> Fragment a -> (Double, Double)
fragmentPos (x, y) self = (x + hbScale (x_min r), y + hbScale (y_min r))
    where r = fragmentRect self

-- | Alter userdata to hold positions.
positionChildren :: (Double, Double) -> ParagraphLayout (a, b, c) ->
                    ParagraphLayout (a, b, ((Double, Double), c))
positionChildren pos self = self {
    paragraphFragments = [
        Fragment (a, b, (pos', c)) d (positionParents pos' e) f g h
        | frag@(Fragment (a, b, c) d e f g h) <- paragraphFragments self,
        let pos' = fragmentPos pos frag]
  }
positionParents :: (Double, Double) -> [AncestorBox (a, b, c)] ->
        [AncestorBox (a, b, ((Double, Double), c))]
positionParents pos (parent@AncestorBox { boxUserData = (a, b, c) }:parents) =
    parent { boxUserData = (a, b, (pos', c)) }:positionParents pos' parents
  where pos' = pos -- FIXME: Take into account borders.
positionParents _ [] = []

data FragmentTree x = Branch (AncestorBox x) [FragmentTree x]
    | Leaf (Fragment x)

reconstructTree :: Eq x => ParagraphLayout x -> [FragmentTree x]
reconstructTree ParagraphLayout { paragraphFragments = frags } =
    reconstructTree' [frag {
            fragmentAncestorBoxes = reverse $ fragmentAncestorBoxes frag
        } | frag <- frags]
reconstructTree' :: Eq x => [Fragment x] -> [FragmentTree x]
reconstructTree' (self@Fragment { fragmentAncestorBoxes = [] }:frags) =
    Leaf self:reconstructTree' frags
reconstructTree' frags@(Fragment {
        fragmentAncestorBoxes = branch:_, fragmentLine = line
  }:_) =
    Branch branch (reconstructTree' [ child { fragmentAncestorBoxes = ancestors }
            | child@Fragment { fragmentAncestorBoxes = _:ancestors } <- childs])
        :reconstructTree' sibs
  where
    (childs, sibs) = span sameBranch frags
    -- Cluster ancestor branches, breaking them per-line.
    sameBranch Fragment {fragmentAncestorBoxes=branch':_, fragmentLine=line'} =
        branch == branch' && line == line'
    -- Leaves are always in their own branch.
    sameBranch Fragment { fragmentAncestorBoxes = [] } = False
reconstructTree' [] = []

positionSubtree :: (Double, Double) ->
        FragmentTree (a, PaddedBox Length Length, c) ->
        FragmentTree (a, PaddedBox Length Length, ((Double, Double), c))
positionSubtree (x, y) self@(Branch (AncestorBox (a, b, c) d e f g) childs) =
    Branch (AncestorBox (a, b, (pos, c)) d e f g) $
        map (positionSubtree pos) childs
  where
    pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))
    rect = treeRect self
positionSubtree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h)) =
    Leaf (Fragment (a, b, (pos, c)) d [] f g h)
  where
    pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))
    rect = treeRect self
subtreeInner :: FragmentTree (a, b, c) -> c
subtreeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret
subtreeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret