From 590ef319be4179b113a8fc2212fe0f27b0dc3daf Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 3 Jul 2023 17:03:15 +1200 Subject: [PATCH] Fix inline sizing, handle length units for callers. --- Graphics/Layout/CSS.hs | 34 ++++++---- Graphics/Layout/CSS/Length.hs | 16 ++++- Graphics/Layout/CSS/Parse.hs | 113 +++++++++++----------------------- Graphics/Layout/Inline.hs | 19 +++--- 4 files changed, 80 insertions(+), 102 deletions(-) diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index 94409ce..cf187d5 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -21,41 +21,48 @@ import Graphics.Layout.Inline.CSS import Data.Char (isSpace) import Graphics.Layout.CSS.Parse +import Data.Maybe (fromMaybe) instance (PropertyParser x, Zero m, Zero n) => Default (UserData m n x) where def = ((placeholderFont, 0), zero, temp) +inner' :: PropertyParser x => Font' -> CSSBox x -> x +inner' f self = foldr apply (inner self) $ innerProperties self + where apply (k, v) ret = fromMaybe ret $ + longhand (innerParent self) ret k $ finalizeLengths f v + -- | Desugar parsed CSS into more generic layout parameters. finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) -> LayoutItem Length Length x finalizeCSS root parent StyleTree { style = self'@CSSBox { display = None } } = - LayoutFlow (inner self') lengthBox [] + LayoutFlow (inner' parent self') lengthBox [] finalizeCSS root parent self@StyleTree { - style = self'@CSSBox { display = Grid, inner = val }, children = childs - } = LayoutFlow val (finalizeBox self' font_) [ + style = self'@CSSBox { display = Grid }, children = childs + } = LayoutFlow (inner' font_ self') (finalizeBox self' font_) [ finalizeGrid (gridStyles self') font_ (map cellStyles $ map style childs) (finalizeChilds root font_ self' childs)] where font_ = pattern2font (font self') (font' self') parent root finalizeCSS root parent self@StyleTree { - style = self'@CSSBox { display = Table, captionBelow = False }, children = childs - } = LayoutFlow (inner self') (finalizeBox self' font_) + style=self'@CSSBox {display=Table, captionBelow=False}, children=childs + } = LayoutFlow (inner' font_ self') (finalizeBox self' font_) ([finalizeCSS root font_ child { style = child' { display = Block } } | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs] ++ [finalizeTable root font_ (inner self') childs]) where font_ = pattern2font (font self') (font' self') parent root finalizeCSS root parent self@StyleTree { - style = self'@CSSBox { display = Table, captionBelow = True }, children = childs - } = LayoutFlow (inner self') (finalizeBox self' font_) + style = self'@CSSBox {display=Table, captionBelow=True}, children = childs + } = LayoutFlow (inner' font_ self') (finalizeBox self' font_) (finalizeTable root font_ temp childs: [finalizeCSS root font_ child { style = child' { display = Block } } | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs]) where font_ = pattern2font (font self') (font' self') parent root finalizeCSS root parent self@StyleTree { - style = self'@CSSBox { inner = val }, children = childs - } = LayoutFlow val (finalizeBox self' font_) (finalizeChilds root font_ self' childs) + style = self', children = childs + } = LayoutFlow (inner' font_ self') (finalizeBox self' font_) + (finalizeChilds root font_ self' childs) where font_ = pattern2font (font self') (font' self') parent root finalizeCSS' sysfont self@StyleTree { style = self' } = @@ -68,10 +75,10 @@ finalizeChilds root parent style' (StyleTree { style = CSSBox { display = None } finalizeChilds root parent style' childs finalizeChilds root parent style' childs@(child:childs') | isInlineTree childs, Just self <- finalizeParagraph (flattenTree0 childs) = - [LayoutInline (inherit $ inner style') self paging] + [LayoutInline (inherit $ inner' parent style') self paging] | (inlines@(_:_), blocks) <- spanInlines childs, Just self <- finalizeParagraph (flattenTree0 inlines) = - LayoutInline (inherit $ inner style') self paging : + LayoutInline (inherit $ inner' parent style') self paging : finalizeChilds root parent style' blocks | (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs = finalizeChilds root parent style' childs' -- Inline's all whitespace... @@ -99,9 +106,10 @@ finalizeChilds root parent style' childs@(child:childs') buildInline f i self $ map (flattenTree f) $ enumerate child where f = pattern2font (font self) (font' self) p root flattenTree f (i,StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _ _}}) - = buildInline f i self [TextSequence ((f,0),zero,inherit $ inner self) txt] + = buildInline f i self [ + TextSequence ((f, 0), zero, inherit $ inner' parent self) txt] buildInline f i self childs = - InlineBox ((f, i), finalizeBox self f, inner self) + InlineBox ((f, i), finalizeBox self f, inner' parent self) (Box childs' $ flip applyFontInline f $ txtOpts self) defaultBoxOptions -- Fill in during layout. where childs' = applyBidi (inlineStyles self) childs diff --git a/Graphics/Layout/CSS/Length.hs b/Graphics/Layout/CSS/Length.hs index 4517040..8b681ec 100644 --- a/Graphics/Layout/CSS/Length.hs +++ b/Graphics/Layout/CSS/Length.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -- | Infrastructure for parsing & desugaring length units & keywords, -- in reference to the selected font. -module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength', - n2f, finalizeLength, px2pt, Font'(..)) where +module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength', units, + n2f, finalizeLength, finalizeLengths, px2pt, Font'(..)) where import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import qualified Data.Text as Txt -import Data.Scientific (toRealFloat) +import Data.Scientific (toRealFloat, fromFloatDigits) import Debug.Trace (trace) -- For warnings. import Data.Text.Glyphize (Font) import Graphics.Text.Font.Choose (Pattern(..)) @@ -27,6 +27,7 @@ parseLength [Percentage _ x] = Just (n2f x,"%") parseLength [Dimension _ x unit] | n2f x == 0 && unit == "" = Just (0,"px") | unit `elem` units = Just (n2f x,unit) +parseLength [Number _ x] | n2f x == 0 = Just (0,"px") parseLength [Ident "auto"] = Just (0,"auto") parseLength [Ident "initial"] = Just (0,"auto") parseLength _ = Nothing @@ -76,6 +77,15 @@ finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels -- | Convert from a computed length to the "pt" unit. px2pt f x = x / scale f / 96 * 72 +-- | Convert any length-units in the given CSS tokens to device pixels +finalizeLengths :: Font' -> [Token] -> [Token] +finalizeLengths f (Dimension _ x unit:toks) + | unit `elem` units, Pixels y <- finalizeLength (n2f x,unit) f = + Dimension "" (NVNumber $ fromFloatDigits y) "px":finalizeLengths f toks +finalizeLengths f (Number a b:ts)|n2f b==0=Dimension a b "px":finalizeLengths f ts +finalizeLengths f (tok:toks) = tok:finalizeLengths f toks +finalizeLengths _ [] = [] + -- | A Harfbuzz font with sizing parameters. data Font' = Font' { -- | The Harfbuzz font used to shape text & query character-size information. diff --git a/Graphics/Layout/CSS/Parse.hs b/Graphics/Layout/CSS/Parse.hs index 67c1118..adf993c 100644 --- a/Graphics/Layout/CSS/Parse.hs +++ b/Graphics/Layout/CSS/Parse.hs @@ -11,13 +11,15 @@ import Data.Text.Glyphize (Direction(..)) import Graphics.Layout.Box as B import Graphics.Text.Font.Choose (Pattern, unset) -import Graphics.Layout.CSS.Length (Unitted, parseLength', parseLength, auto) +import Graphics.Layout.CSS.Length (Unitted, parseLength', parseLength, auto, units) import Graphics.Layout.CSS.Font (CSSFont) import Graphics.Layout.Grid.CSS (CSSGrid(..), CSSCell(..), Placement(..)) import Graphics.Layout.Inline.CSS (CSSInline(..)) import Data.Maybe (isJust, fromMaybe) import qualified Data.HashMap.Lazy as HM +import Data.Text (Text) +import Debug.Trace (trace) -- For debug warnings. -- | Parsed CSS properties relevant to layout. data CSSBox a = CSSBox { @@ -34,6 +36,10 @@ data CSSBox a = CSSBox { font' :: CSSFont, -- | Caller-specified data, to parse additional CSS properties. inner :: a, + -- | Properties to lower size units before passing onto to `inner` + innerProperties :: [(Text, [Token])], + -- | Parent to use when parsing length-expanded inner properties. + innerParent :: a, -- | Grid-related CSS properties. gridStyles :: CSSGrid, -- | Grid item related CSS properties. @@ -80,6 +86,9 @@ instance PropertyParser a => PropertyParser (CSSBox a) where font = temp, font' = temp, inner = temp, + innerProperties = [], + innerParent = trace ("Parent not overriden upon " ++ + "buffering inner properties for length resolution!") temp, gridStyles = temp, cellStyles = temp, inlineStyles = temp, @@ -96,6 +105,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where font = inherit $ font parent, font' = inherit $ font' parent, inner = inherit $ inner parent, + innerProperties = [], + innerParent = inner parent, gridStyles = inherit $ gridStyles parent, cellStyles = inherit $ cellStyles parent, inlineStyles = inherit $ inlineStyles parent, @@ -266,6 +277,12 @@ instance PropertyParser a => PropertyParser (CSSBox a) where Just b { gridStyles = grid' } longhand a b c d | Just cell' <- longhand (cellStyles a) (cellStyles b) c d = Just b { cellStyles = cell' } + longhand a b c d + | (d', _:_)<-testLengthProp d, Just _<-longhand (inner a) (inner b) c d' = + Just b { + innerProperties = (c, d):innerProperties b, + innerParent = inner a + } longhand a b c d | Just inner' <- longhand (inner a) (inner b) c d = Just b { inner = inner' } @@ -346,88 +363,28 @@ instance PropertyParser a => PropertyParser (CSSBox a) where [("border-top-width", top), ("border-right-width", right), ("border-bottom-width", bottom), ("border-left-width", left)] where x = parseOperands toks - -- Define other border shorthands here to properly handle border-widths - shorthand self "border" toks = parseUnorderedShorthand self [ - "border-color", "border-style", "border-width"] toks - shorthand self "border-top" toks = parseUnorderedShorthand self [ - "border-top-color", "border-top-style", "border-top-width"] toks - shorthand self "border-right" toks = parseUnorderedShorthand self [ - "border-right-color", "border-right-style", "border-right-width"] toks - shorthand self "border-bottom" toks = parseUnorderedShorthand self [ - "border-bottom-color", "border-bottom-style", "border-bottom-width"] toks - shorthand self "border-left" toks = parseUnorderedShorthand self [ - "border-left-color", "border-left-style", "border-left-width"] toks - shorthand self "border-inline" toks = parseUnorderedShorthand self [ - "border-inline-color", "border-inline-style", "border-inline-width"] toks - shorthand self "border-inline-start" toks = parseUnorderedShorthand self [ - "border-inline-start-color", "border-inline-start-style", - "border-inline-start-width"] toks - shorthand self "border-inline-end" toks = parseUnorderedShorthand self [ - "border-inline-end-color", "border-inline-end-style", - "border-inline-end-width"] toks - shorthand self "border-block" toks = parseUnorderedShorthand self [ - "border-block-color", "border-block-style", "border-block-width"] toks - shorthand self "border-block-start" toks = parseUnorderedShorthand self [ - "border-block-start-color", "border-block-start-style", - "border-block-start-width"] toks - shorthand self "border-block-end" toks = parseUnorderedShorthand self [ - "border-block-end-color", "border-block-end-style", - "border-block-end-width"] toks - shorthand self "border-color" toks - | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, - all (validProp self "border-top-color") x = - [("border-top-color", top), ("border-right-color", right), - ("border-bottom-color", bottom), ("border-left-color", left)] - where x = parseOperands toks - shorthand self "border-style" toks - | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, - all (validProp self "border-top-style") x = - [("border-top-style", top), ("border-right-style", right), - ("border-bottom-style", bottom), ("border-left-style", left)] - where x = parseOperands toks - shorthand self "border-width" toks - | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, - all (validProp self "border-top-width") x = - [("border-top-width", top), ("border-right-width", right), - ("border-bottom-width", bottom), ("border-left-width", left)] - where x = parseOperands toks - shorthand self "border-inline-color" toks - | length x > 0 && length x <= 2, (s:e:_) <- cycle x, - all (validProp self "border-inline-start-color") x = - [("border-inline-start-color", s), ("border-inline-end-color", e)] - where x = parseOperands toks - shorthand self "border-inline-style" toks - | length x > 0 && length x <= 2, (s:e:_) <- cycle x, - all (validProp self "border-inline-start-style") x = - [("border-inline-start-style", s), ("border-inline-end-style", e)] - where x = parseOperands toks - shorthand self "border-inline-width" toks - | length x > 0 && length x <= 2, (s:e:_) <- cycle x, - all (validProp self "border-inline-start-width") x = - [("border-inline-start-width", s), ("border-inline-end-style", e)] - where x = parseOperands toks - shorthand self "border-block-color" toks - | length x > 0 && length x <= 2, (s:e:_) <- cycle x, - all (validProp self "border-block-start-color") x = - [("border-block-start-color", s), ("border-block-end-color", e)] - where x = parseOperands toks - shorthand self "border-block-style" toks - | length x > 0 && length x <= 2, (s:e:_) <- cycle x, - all (validProp self "border-block-start-style") x = - [("border-block-start-style", s), ("border-block-end-style", e)] - where x = parseOperands toks - shorthand self "border-block-width" toks - | length x > 0 && length x <= 2, (s:e:_) <- cycle x, - all (validProp self "border-block-start-width") x = - [("border-block-start-width", s), ("border-block-end-width", e)] - where x = parseOperands toks - shorthand self k v | Just _ <- longhand self self k v = [(k, v)] shorthand self k v | ret@(_:_) <- shorthand (font self) k v = ret shorthand self k v | ret@(_:_) <- shorthand (font' self) k v = ret shorthand self k v | ret@(_:_) <- shorthand (inlineStyles self) k v = ret shorthand self k v | ret@(_:_) <- shorthand (gridStyles self) k v = ret shorthand self k v | ret@(_:_) <- shorthand (cellStyles self) k v = ret - shorthand self k v = shorthand (inner self) k v + shorthand self k v | ret@(_:_) <- shorthand (inner self) k v = ret + shorthand self k v + | (v', ls)<-testLengthProp v, ret@(_:_)<-shorthand (inner self) k v' = + [(key, map (restore ls) value) | (key, value) <- ret] + where + restore ls (Dimension _ (NVInteger x) "px") | x' < length ls = ls !! x' + where x' = fromInteger x + restore _ ret = ret + shorthand self k v | Just _ <- longhand self self k v = [(k, v)] + | otherwise = [] validProp self key value = isJust $ longhand self self key value + +testLengthProp (tok@(Dimension _ _ unit):toks) | unit `elem` units = + let (toks', lengths) = testLengthProp toks + in (Dimension "" (NVInteger $ toInteger $ succ $ length lengths) "px":toks', + tok:lengths) +testLengthProp (tok:toks) = let (toks',ls) = testLengthProp toks in (tok:toks',ls) +testLengthProp [] = ([], []) diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs index 15a1e1e..bdc70e2 100644 --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -9,7 +9,7 @@ import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), Fragment(..), ParagraphLayout(..), AncestorBox(..), InnerNode(..), Box(..), RootNode(..), layoutRich, boxSpacing, BoxSpacing(..), - activateBoxSpacing) + activateBoxSpacing, paragraphSafeWidth) import Data.Text.ParagraphLayout.Rect (Rect(..), width, height, x_max, x_min, y_min, y_max) import Data.Int (Int32) @@ -32,12 +32,12 @@ unscale = floor . (*hbUnit) . toDouble -- | 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 +inlineMin = layoutSize' . flip layoutRich' 0 -- | Compute width & height of some richtext at configured width. inlineSize :: (CastDouble x, CastDouble y) => Paragraph (a, PaddedBox x y, c) -> Size x y -inlineSize self = layoutSize $ layoutRich $ lowerSpacing self +inlineSize self@(Paragraph _ _ _ opts) = + layoutSize' . layoutRich' self $ paragraphMaxWidth opts -- | Retrieve children out of some richtext, -- associating given userdata with them. inlineChildren :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq a, Eq c) => @@ -46,17 +46,20 @@ inlineChildren self = layoutChildren $ layoutRich $ lowerSpacing 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 +layoutSize = layoutSize' . paragraphRect +layoutSize' r = Size (c $ width r) (c $ height r) -- | 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. +-- LEGACY. 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 } +layoutRich' (Paragraph a b c d) width = + (paragraphRect layout) { x_size = paragraphSafeWidth layout} + where + layout = layoutRich$lowerSpacing$Paragraph a b c d {paragraphMaxWidth=width} -- | Copy surrounding whitespace into Balkon properties. lowerSpacing :: (CastDouble m, CastDouble n) => -- 2.30.2