{-# 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, treeBox, FragmentTree(..),
    positionSubtree, subtreeInner, paragraphMap, layoutMap, treeMap) where

import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
                                Fragment(..), ParagraphLayout(..), AncestorBox(..),
                                InnerNode(..), Box(..), RootNode(..),
                                layoutRich, boxSpacing, BoxSpacing(..))
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 hiding (min, max, width, height)
import qualified Graphics.Layout.Box as Box
import Graphics.Layout.CSS.Font (Font', hbUnit)

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

-- | Compute minimum width for some richtext.
inlineMinWidth :: (CastDouble m, CastDouble n) =>
        Paragraph (a, PaddedBox m n, c) -> Double
inlineMinWidth self = hbScale $ width $ layoutRich' self 0
-- | Compute minimum width & height for some richtext.
inlineMin :: (CastDouble x, CastDouble y) =>
        Paragraph (a, PaddedBox x y, c) -> 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 :: (CastDouble m, CastDouble n) =>
        Paragraph (a, PaddedBox m n, c) -> Double
inlineNatWidth self = hbScale $ width $ layoutRich' self maxBound
-- | Compute height for rich text at given width.
inlineHeight :: (CastDouble m, CastDouble n) =>
        Double -> Paragraph (a, PaddedBox m n, c) -> 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' :: (CastDouble m, CastDouble n) =>
        Paragraph (a, PaddedBox m n, c) -> Int32 -> Rect Int32
layoutRich' (Paragraph a b c d) width = paragraphRect $ layoutRich $
    lowerSpacing $ Paragraph a b c d { paragraphMaxWidth = width }

lowerSpacing :: (CastDouble m, CastDouble n) =>
    Paragraph (a, PaddedBox m n, c) -> Paragraph (a, PaddedBox m n, c)
lowerSpacing (Paragraph a b (RootBox c) d) = Paragraph a b (RootBox $ inner c) d
  where
    inner (Box childs opts) = flip Box opts $ map inner' childs
    inner' (InlineBox e@(_, f, _) child opts) = InlineBox e (inner child) opts {
            boxSpacing = BoxSpacingLeftRight (leftSpace box) (rightSpace box)
        }
      where box = mapX' unscale $ mapY' unscale f
    inner' self@(TextSequence _ _) = self

-- | Apply an operation to the 2nd field of the paragraph's userdata,
-- for it's entire subtree.
paragraphMap :: (b -> b') -> Paragraph (a, b, c) -> Paragraph (a, b', c)
paragraphMap cb (Paragraph a b (RootBox c) d) =
    Paragraph a b (RootBox $ inner c) d
  where
    inner (Box childs opts) = flip Box opts $ map inner' childs
    inner' (InlineBox (e, f, g) child opts) =
        InlineBox (e, cb f, g) (inner child) opts
    inner' (TextSequence (e, f, g) leaf) = TextSequence (e, cb f, g) leaf

-- | Apply an operation to the 2nd field of a laid-out paragraph's userdata,
-- for it's entire subtree.
layoutMap :: (b -> b') -> ParagraphLayout (a, b, c) -> ParagraphLayout (a, b', c)
layoutMap cb (ParagraphLayout a b) = ParagraphLayout a $ map inner b
  where
    inner self@Fragment { fragmentUserData = (a, b, c) } = self {
        fragmentUserData = (a, cb b, c),
        fragmentAncestorBoxes = map inner' $ fragmentAncestorBoxes self
      }
    inner' self@AncestorBox { boxUserData = (a, b, c) } = self {
        boxUserData = (a, cb b, c)
      }

-- | Apply an operation to the 2nd field of the tree extracted from a laid-out
-- paragraph, for all nodes.
treeMap :: (b -> b') -> FragmentTree (a, b, c) -> FragmentTree (a, b', c)
treeMap cb (Branch self@AncestorBox { boxUserData = (a, b, c) } childs) =
    Branch self { boxUserData = (a, cb b, c) } $ map (treeMap cb) childs
treeMap cb (Leaf self@Fragment { fragmentUserData = (a, b, c) }) =
    Leaf self { fragmentUserData = (a, cb b, c), fragmentAncestorBoxes = [] }

-- | Retrieve the rect for a fragment & convert to CatTrap types.
fragmentSize :: (CastDouble x, CastDouble y) =>
        FragmentTree (a, PaddedBox x y, 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 AncestorBox { boxUserData = (_, box', _)} childs) =
        foldr unionRect (Rect 0 0 0 0) $ map treeRect childs
    where
        unionRect a b = Rect
            (x_min a `min` x_min b - leftSpace box)
            (y_min a `min` y_min b - topSpace box)
            (x_max a `max` x_max b - x_min a `min` x_min b + hSpace box)
            (y_max a `max` y_max b - y_min a `min` x_min b + vSpace box)
        box :: PaddedBox Int32 Int32
        box = mapX' unscale $ mapY' unscale box'
treeRect (Leaf self) = fragmentRect self

-- | Compute the paddedbox for a subtree.
treeBox :: (CastDouble m, CastDouble n) =>
    FragmentTree (a, PaddedBox m n, c) -> PaddedBox m n
treeBox self@(Branch AncestorBox { boxUserData = (_, box', _)} _) = box' {
    Box.min = size', Box.max = size', Box.size = size', Box.nat = size
  } where
    size' = mapSizeX fromDouble $ mapSizeY fromDouble size
    size = mapSizeX (subtract $ hSpace box) $ mapSizeY (subtract $ vSpace box)$
         mapSizeX toDouble $ mapSizeY toDouble $ fragmentSize self
    box = mapX' toDouble $ mapY' toDouble box'
treeBox self@(Leaf Fragment { fragmentUserData = (_, box', _)}) = box' {
    Box.min = size', Box.max = size', Box.size = size', Box.nat = size
  } where
    size' = mapSizeX fromDouble $ mapSizeY fromDouble size
    size = mapSizeX (subtract $ hSpace box) $ mapSizeY (subtract $ vSpace box) $
        mapSizeX toDouble $ mapSizeY toDouble $ fragmentSize self
    box = mapX' toDouble $ mapY' toDouble box'

-- | 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 x x, 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 :: (CastDouble m, CastDouble n) => (Double, Double) ->
        FragmentTree (a, PaddedBox m n, c) ->
        FragmentTree (a, PaddedBox m n, ((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