From 85d144a03f9b1010423c53b2addffa1f77762178 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 7 Apr 2023 13:15:19 +1200 Subject: [PATCH] Integrate paragraph pagination via Balkon. --- Graphics/Layout.hs | 72 +++++++++++++++++++++++++++++---------- Graphics/Layout/CSS.hs | 5 +-- Graphics/Layout/Inline.hs | 14 +++++--- 3 files changed, 67 insertions(+), 24 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index 1c2c17a..388e7e6 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -5,7 +5,9 @@ module Graphics.Layout(LayoutItem(..), boxNatHeight, boxMinHeight, boxMaxHeight, boxHeight, boxSplit, boxPaginate, boxPosition, boxLayout, glyphsPerFont) where -import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), PageOptions(..), Fragment(..)) +import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), Fragment(..), + ParagraphLayout(..), PageOptions(..), PageContinuity(..), paginate, layoutPlain) +import Stylist (PropertyParser(..)) import Graphics.Layout.Box as B import Graphics.Layout.Grid as G @@ -25,8 +27,11 @@ data LayoutItem m n x = LayoutFlow x (PaddedBox m n) [LayoutItem m n x] | LayoutGrid x (Grid m n) [(GridItem m n, LayoutItem m n x)] | LayoutInline x Font' Paragraph PageOptions [x] -- Balkon holds children. + | LayoutInline' x Font' ParagraphLayout PageOptions [x] | LayoutSpan x Font' Fragment -- More to come... +nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x +nullLayout = LayoutFlow temp zero [] layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) => LayoutItem m n x -> PaddedBox m n @@ -36,9 +41,12 @@ layoutGetBox (LayoutGrid _ self _) = zero { B.size = containerSize self, B.max = containerMax self } -layoutGetBox (LayoutInline _ f self _) = zero { +layoutGetBox (LayoutInline _ f self _ _) = zero { B.min = inlineMin f self, B.size = inlineSize f self, B.max = inlineSize f self } +layoutGetBox (LayoutInline' _ f self _ _) = zero { + B.min = layoutSize f self, B.size = layoutSize f self, B.max = layoutSize f self +} layoutGetBox (LayoutSpan _ f self) = zero { B.min = fragmentSize f self, B.size = fragmentSize f self, B.max = fragmentSize f self } @@ -47,9 +55,12 @@ layoutGetChilds (LayoutGrid _ _ ret) = map snd ret layoutGetChilds (LayoutSpan _ _ _) = [] layoutGetChilds (LayoutInline _ font self _ vals) = map inner $ inlineChildren vals self where inner (val, fragment) = LayoutSpan val font fragment +layoutGetChilds (LayoutInline' _ font self _ vals) = map inner $ layoutChildren vals self + where inner (val, fragment) = LayoutSpan val font fragment layoutGetInner (LayoutFlow ret _ _) = ret layoutGetInner (LayoutGrid ret _ _) = ret layoutGetInner (LayoutInline ret _ _ _ _) = ret +layoutGetInner (LayoutInline' ret _ _ _ _) = ret layoutGetInner (LayoutSpan ret _ _) = ret setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child } @@ -82,7 +93,8 @@ boxMinWidth parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip cel (GridItem {..}, _) <- childs]) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxMinWidth _ self@(LayoutInline _ _ _ _) = self +boxMinWidth _ self@(LayoutInline _ _ _ _ _) = self +boxMinWidth _ self@(LayoutInline' _ _ _ _ _) = self boxMinWidth _ self@(LayoutSpan _ _ _) = self boxNatWidth :: (Zero y, CastDouble y) => Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x @@ -114,7 +126,8 @@ boxNatWidth parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip cel (GridItem {..}, _) <- childs]) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxNatWidth _ self@(LayoutInline _ _ _ _) = self +boxNatWidth _ self@(LayoutInline _ _ _ _ _) = self +boxNatWidth _ self@(LayoutInline' _ _ _ _ _) = self boxNatWidth _ self@(LayoutSpan _ _ _) = self boxMaxWidth :: PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' @@ -127,7 +140,8 @@ boxMaxWidth parent (LayoutGrid val self childs) = LayoutGrid val self' childs where self' = self { containerMax = Size (Pixels max') (block $ containerMax self) } (max', _) = gridMaxWidths parent self $ colBounds self -boxMaxWidth parent self@(LayoutInline _ _ _ _) = self +boxMaxWidth parent self@(LayoutInline _ _ _ _ _) = self +boxMaxWidth parent self@(LayoutInline' _ _ _ _ _) = self boxMaxWidth parent self@(LayoutSpan _ f self') = self boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x -> LayoutItem y Double x @@ -164,9 +178,10 @@ boxWidth parent (LayoutGrid val self childs) = LayoutGrid val self' childs' } outerwidth = inline $ size parent (size', widths) = gridWidths parent self $ colBounds self -boxWidth parent (LayoutInline val font (Paragraph a b c d) vals) = - LayoutInline val font (Paragraph a b c d { paragraphMaxWidth = round width }) vals +boxWidth parent (LayoutInline val font (Paragraph a b c d) paging vals) = + LayoutInline val font (Paragraph a b c d { paragraphMaxWidth = round width }) paging vals where width = B.inline $ B.size parent +boxWidth _ (LayoutInline' a b c d e) = LayoutInline' a b c d e boxWidth parent (LayoutSpan val font self') = LayoutSpan val font self' boxNatHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x @@ -188,7 +203,8 @@ boxNatHeight parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip ce cells = map setCellBox' $ zip childs' $ map fst childs childs' = map (boxNatHeight width) $ map snd childs width = inline $ containerSize self -boxNatHeight parent self@(LayoutInline _ _ _ _) = self +boxNatHeight parent self@(LayoutInline _ _ _ _ _) = self +boxNatHeight parent self@(LayoutInline' _ _ _ _ _) = self boxNatHeight parent self@(LayoutSpan _ _ _) = self boxMinHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x boxMinHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' @@ -214,7 +230,8 @@ boxMinHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs' startCol = startCol cell, endCol = endCol cell, alignment = alignment cell } | (cell, _) <- childs] width = inline $ containerSize self -boxMinHeight parent self@(LayoutInline _ font self' _) = self +boxMinHeight parent self@(LayoutInline _ _ _ _ _) = self +boxMinHeight _ self@(LayoutInline' _ _ _ _ _) = self boxMinHeight parent self@(LayoutSpan _ font self') = self boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Length Double x @@ -242,7 +259,10 @@ boxMaxHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs' } (max', heights) = gridMaxHeights parent self $ rowBounds self width = inline $ size parent -boxMaxHeight parent (LayoutInline val font self' vals) = LayoutInline val font self' vals +boxMaxHeight parent (LayoutInline val font self' paging vals) = + LayoutInline val font self' paging vals +boxMaxHeight parent (LayoutInline' val font self' paging vals) = + LayoutInline' val font self' paging vals boxMaxHeight parent (LayoutSpan val font self') = LayoutSpan val font self' boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Double Double x boxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' @@ -274,10 +294,13 @@ boxHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs' lowerSize (Left x) = Left $ lowerLength width x lowerSize (Right x) = Right x width = inline $ size parent -boxHeight parent (LayoutInline val font self' vals) = LayoutInline val font self' vals +boxHeight parent (LayoutInline val font self' paging vals) = + LayoutInline val font self' paging vals +boxHeight _ (LayoutInline' val font self' paging vals) = + LayoutInline' val font self' paging vals boxHeight _ (LayoutSpan val font self') = LayoutSpan val font self' -boxSplit :: Double -> Double -> LayoutItem Double Double x -> +boxSplit :: PropertyParser x => Double -> Double -> LayoutItem Double Double x -> (LayoutItem Double Double x, Maybe (LayoutItem Double Double x)) boxSplit maxheight _ node | height (layoutGetBox node) <= maxheight = (node, Nothing) boxSplit maxheight pageheight (LayoutFlow val self childs) @@ -301,14 +324,24 @@ boxSplit maxheight pageheight (LayoutFlow val self childs) where start' = start + height (layoutGetBox child) inner _ [] = [] boxSplit _ _ self@(LayoutGrid _ _ _) = (self, Nothing) -- TODO -boxSplit _ _ self@(LayoutInline _ _ _ _) = (self, Nothing) -- TODO +boxSplit maxheight pageheight (LayoutInline a b self c d) = + boxSplit maxheight pageheight $ LayoutInline' a b (layoutPlain self) c d +boxSplit maxheight pageheight (LayoutInline' a b self paging c) = + case paginate paging { + pageCurrentHeight = toEnum $ fromEnum maxheight, + pageNextHeight = toEnum $ fromEnum pageheight + } self of + (Continue, self', next) -> (wrap self', wrap <$> next) + (Break, _, _) -> (nullLayout, Just $ wrap self) + where + wrap self' = LayoutInline' a b self' paging c boxSplit _ _ self@(LayoutSpan _ _ _) = (self, Nothing) -- Can't split! boxPaginate maxheight pageheight node | (page, Just overflow) <- boxSplit maxheight pageheight node = page:boxPaginate maxheight pageheight overflow | otherwise = [node] -boxPosition :: (Double, Double) -> LayoutItem Double Double x -> +boxPosition :: PropertyParser x => (Double, Double) -> LayoutItem Double Double x -> LayoutItem Double Double ((Double, Double), x) boxPosition pos@(x, y) (LayoutFlow val self childs) = LayoutFlow (pos, val) self childs' where @@ -320,12 +353,15 @@ boxPosition pos@(x, y) (LayoutGrid val self childs) = LayoutGrid (pos, val) self childs' = map recurse $ zip pos' childs recurse ((Size x' y'), (cell, child)) = (cell, boxPosition (x + x', y + y') child) pos' = gridPosition self $ map fst childs -boxPosition pos@(x, y) (LayoutInline val font self vals) = - LayoutInline (pos, val) font self $ map (\(x, y) -> (fragmentPos font pos y, x)) $ +boxPosition pos@(x, y) (LayoutInline val font self paging vals) = + LayoutInline (pos, val) font self paging $ map (\(x, y) -> (fragmentPos font pos y, x)) $ inlineChildren vals self +boxPosition pos@(x, y) (LayoutInline' val font self paging vals) = + LayoutInline' (pos, val) font self paging $ map (\(x, y) -> (fragmentPos font pos y, x)) $ + layoutChildren vals self boxPosition pos (LayoutSpan val f self) = LayoutSpan (pos, val) f self -- No children... -boxLayout :: PaddedBox Double Double -> LayoutItem Length Length x -> Bool -> - LayoutItem Double Double ((Double, Double), x) +boxLayout :: PropertyParser x => PaddedBox Double Double -> LayoutItem Length Length x -> + Bool -> LayoutItem Double Double ((Double, Double), x) boxLayout parent self paginate = self8 where self0 = boxMinWidth Nothing self diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index 6aef096..394e53a 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -215,15 +215,16 @@ finalizeChilds root parent style' childs@(child:childs') -- FIXME propagate display properties, how to handle the hierarchy. -- NOTE: Playing around in firefox, it appears the CSS borders should cover -- their entire span, doubling up on borders where needed. - [LayoutInline (inherit style') parent self (repeat $ inherit style')] + [LayoutInline (inherit style') parent self paging (repeat $ inherit style')] | (inlines@(_:_), blocks) <- spanInlines childs, Just self <- finalizeParagraph (flattenTree inlines) parent = - LayoutInline (inherit style') parent self (repeat $ inherit style') : + LayoutInline (inherit style') parent self paging (repeat $ inherit style') : finalizeChilds root parent style' blocks | (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs = finalizeChilds root parent style' childs' -- Inline's all whitespace... | otherwise = finalizeCSS root parent child : finalizeChilds root parent style' childs' where + paging = pageOptions $ style child isInlineTree = all isInlineTree0 isInlineTree0 StyleTree { style = CSSBox { display = Inline }, children = childs } = isInlineTree childs diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs index 2c57993..6828d55 100644 --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TupleSections #-} module Graphics.Layout.Inline(inlineMinWidth, inlineMin, inlineNatWidth, inlineHeight, - inlineSize, inlineChildren, fragmentSize, fragmentSize', fragmentPos) where + inlineSize, inlineChildren, layoutSize, layoutChildren, + fragmentSize, fragmentSize', fragmentPos) where import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), SpanLayout(..), Fragment(..), @@ -29,10 +30,15 @@ inlineHeight font width self = hbScale' font $ height $ layoutPlain' self $ round (hbScale font * width) inlineSize :: (CastDouble x, CastDouble y) => Font' -> Paragraph -> Size x y -inlineSize font self = Size (c font $ width r) (c font $ height r) - where r = paragraphRect $ layoutPlain self +inlineSize font self = layoutSize font $ layoutPlain self inlineChildren :: [x] -> Paragraph -> [(x, Fragment)] -inlineChildren vals self = zip vals $ concat $ map inner $ spanLayouts $ layoutPlain self +inlineChildren vals self = layoutChildren vals $ layoutPlain self + +layoutSize :: (CastDouble x, CastDouble y) => Font' -> ParagraphLayout -> Size x y +layoutSize font self = Size (c font $ width r) (c font $ height r) + where r = paragraphRect self +layoutChildren :: [x] -> ParagraphLayout -> [(x, Fragment)] +layoutChildren vals self = zip vals $ concat $ map inner $ spanLayouts self where inner (SpanLayout y) = y layoutPlain' :: Paragraph -> Int32 -> Rect Int32 -- 2.30.2