From b07f5dcbcf23cb75b2db2022f807d3847505a0bf Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 29 May 2023 13:25:26 +1200 Subject: [PATCH] =?UTF-8?q?Refactor=20to=20use=20newer=20Balk=C3=B3n=20API?= =?UTF-8?q?s.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add support for logical properties thanks to Stylist Traits update. --- Graphics/Layout.hs | 123 ++++++++++++------------- Graphics/Layout/CSS.hs | 167 ++++++++++++++++++++++++++++++---- Graphics/Layout/CSS/Font.hs | 7 +- Graphics/Layout/Inline.hs | 77 +++++++++------- Graphics/Layout/Inline/CSS.hs | 62 +++++-------- cattrap.cabal | 2 +- 6 files changed, 281 insertions(+), 157 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index a7d2f0d..f79d205 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -8,10 +8,11 @@ module Graphics.Layout(LayoutItem(..), layoutGetBox, layoutGetChilds, layoutGetInner, boxMinWidth, boxMaxWidth, boxNatWidth, boxWidth, boxNatHeight, boxMinHeight, boxMaxHeight, boxHeight, - boxSplit, boxPaginate, boxPosition, boxLayout, glyphsPerFont) where + boxSplit, boxPaginate, boxPosition, boxLayout{-, glyphsPerFont-}) where -import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), Fragment(..), - ParagraphLayout(..), PageOptions(..), PageContinuity(..), paginate, layoutPlain) +import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), + Fragment(..), ParagraphLayout(..), layoutRich) +import Data.Text.ParagraphLayout (paginate, PageContinuity(..), PageOptions(..)) import Stylist (PropertyParser(..)) import Graphics.Layout.Box as B @@ -28,6 +29,9 @@ import qualified Data.Map.Strict as M import qualified Data.Text.Glyphize as Hb import Graphics.Text.Font.Choose (Pattern) +-- | Additional data routed through Balkon. +type UserData x = (Font', PaddedBox Length Length, x) + -- | A tree of different layout algorithms. -- More to come... data LayoutItem m n x = @@ -36,12 +40,12 @@ data LayoutItem m n x = -- | A grid or table element. | LayoutGrid x (Grid m n) [GridItem] [LayoutItem m n x] -- | Some richtext. - | LayoutInline x Font' Paragraph PageOptions [x] -- Balkon holds children. + | LayoutInline x (Paragraph (UserData x)) PageOptions -- Balkon holds children. -- | Results laying out richtext, has fixed width. -- Generated from `LayoutInline` for the sake of pagination. - | LayoutInline' x Font' ParagraphLayout PageOptions [x] + | LayoutInline' x (ParagraphLayout (UserData x)) PageOptions -- | Children of a `LayoutInline` or `LayoutInline'`. - | LayoutSpan x Font' Fragment + | LayoutSpan (Fragment (UserData x)) -- | An empty box. nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x nullLayout = LayoutFlow temp zero [] @@ -58,29 +62,27 @@ layoutGetBox (LayoutGrid _ self _ _) = zero { B.max = Size (fromDouble $ trackNat toDouble $ inline self) (fromDouble $ trackNat toDouble $ block self) } -layoutGetBox (LayoutInline _ f self _ _) = zero { - B.min = inlineMin f self, B.size = inlineSize f self, B.max = inlineSize f self +layoutGetBox (LayoutInline _ self _) = zero { + B.min = inlineMin self, B.size = inlineSize self, B.max = inlineSize self } -layoutGetBox (LayoutInline' _ f self _ _) = zero { - B.min = layoutSize f self, B.size = layoutSize f self, B.max = layoutSize f self +layoutGetBox (LayoutInline' _ self _) = zero { + B.min = layoutSize self, B.size = layoutSize self, B.max = layoutSize self } -layoutGetBox (LayoutSpan _ f self) = zero { - B.min = fragmentSize f self, B.size = fragmentSize f self, B.max = fragmentSize f self +layoutGetBox (LayoutSpan self) = zero { + B.min = fragmentSize self, B.size = fragmentSize self, B.max = fragmentSize self } -- | Retrieve the subtree under a node. layoutGetChilds (LayoutFlow _ _ ret) = ret layoutGetChilds (LayoutGrid _ _ _ ret) = 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 +layoutGetChilds (LayoutSpan _) = [] +layoutGetChilds (LayoutInline _ self _) = map LayoutSpan $ inlineChildren self +layoutGetChilds (LayoutInline' _ self _) = map LayoutSpan $ layoutChildren self -- | Retrieve the caller-specified data attached to a layout node. layoutGetInner (LayoutFlow ret _ _) = ret layoutGetInner (LayoutGrid ret _ _ _) = ret -layoutGetInner (LayoutInline ret _ _ _ _) = ret -layoutGetInner (LayoutInline' ret _ _ _ _) = ret -layoutGetInner (LayoutSpan ret _ _) = ret +layoutGetInner (LayoutInline ret _ _) = ret +layoutGetInner (LayoutInline' ret _ _) = ret +layoutGetInner (LayoutSpan Fragment { fragmentUserData = (_, _, ret) }) = ret -- | map-ready wrapper around `setCellBox` sourcing from a child node. setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child @@ -107,9 +109,9 @@ boxMinWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' ce parent' = fromMaybe (gridEstWidth self cells0) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxMinWidth _ self@(LayoutInline _ _ _ _ _) = self -boxMinWidth _ self@(LayoutInline' _ _ _ _ _) = self -boxMinWidth _ self@(LayoutSpan _ _ _) = self +boxMinWidth _ self@(LayoutInline _ _ _) = self +boxMinWidth _ self@(LayoutInline' _ _ _) = self +boxMinWidth _ self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache ideal width. boxNatWidth :: (Zero y, CastDouble y) => Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x @@ -132,9 +134,9 @@ boxNatWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' ce parent' = fromMaybe (gridEstWidth self cells0) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxNatWidth _ self@(LayoutInline _ _ _ _ _) = self -boxNatWidth _ self@(LayoutInline' _ _ _ _ _) = self -boxNatWidth _ self@(LayoutSpan _ _ _) = self +boxNatWidth _ self@(LayoutInline _ _ _) = self +boxNatWidth _ self@(LayoutInline' _ _ _) = self +boxNatWidth _ self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache maximum legible width. boxMaxWidth :: CastDouble y => PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' @@ -149,9 +151,9 @@ boxMaxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self cell inner (Size cellx celly, child) = boxMaxWidth (cellSize (inline self) cellx `size2box` cellSize (block self) celly) child size2box x y = zeroBox { B.min = Size x y, B.max = Size x y, B.size = Size x y } -boxMaxWidth parent self@(LayoutInline _ _ _ _ _) = self -boxMaxWidth parent self@(LayoutInline' _ _ _ _ _) = self -boxMaxWidth parent self@(LayoutSpan _ f self') = self +boxMaxWidth parent self@(LayoutInline _ _ _) = self +boxMaxWidth parent self@(LayoutInline' _ _ _) = self +boxMaxWidth parent self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache final width. boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x -> LayoutItem y Double x @@ -176,11 +178,11 @@ boxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells' } outerwidth = inline $ size parent widths = sizeTrackMaxs (inline $ size parent) $ inline self -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 +boxWidth parent (LayoutInline val (Paragraph a b c d) paging) = + LayoutInline val (Paragraph a b c d { paragraphMaxWidth = round width }) paging 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' +boxWidth _ (LayoutInline' a b c) = LayoutInline' a b c +boxWidth parent (LayoutSpan self') = LayoutSpan self' -- | Update a (sub)tree to compute & cache ideal legible height. boxNatHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x @@ -197,9 +199,9 @@ boxNatHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' ce cells' = map setCellBox' $ zip childs' cells -- Flatten subgrids childs' = map (boxNatHeight width) childs width = trackNat id $ inline self -boxNatHeight parent self@(LayoutInline _ _ _ _ _) = self -boxNatHeight parent self@(LayoutInline' _ _ _ _ _) = self -boxNatHeight parent self@(LayoutSpan _ _ _) = self +boxNatHeight parent self@(LayoutInline _ _ _) = self +boxNatHeight parent self@(LayoutInline' _ _ _) = self +boxNatHeight parent self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache minimum legible height. boxMinHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x boxMinHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' @@ -217,9 +219,9 @@ boxMinHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' ce self' = Size (inline self) (block self) { trackMins = heights } heights = sizeTrackMins width (block self) $ map block cells width = trackNat id $ inline self -boxMinHeight parent self@(LayoutInline _ _ _ _ _) = self -boxMinHeight _ self@(LayoutInline' _ _ _ _ _) = self -boxMinHeight parent self@(LayoutSpan _ font self') = self +boxMinHeight parent self@(LayoutInline _ _ _) = self +boxMinHeight _ self@(LayoutInline' _ _ _) = self +boxMinHeight parent self@(LayoutSpan _) = self -- | Update a subtree to compute & cache maximum legible height. boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Length Double x @@ -238,11 +240,9 @@ boxMaxHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self cel child' = boxMaxHeight (gridItemBox self cell) child heights = sizeTrackMaxs (inline $ size parent) (block self) width = inline $ size parent -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' +boxMaxHeight _ (LayoutInline val self' paging) = LayoutInline val self' paging +boxMaxHeight _ (LayoutInline' val self' paging) = LayoutInline' val self' paging +boxMaxHeight parent (LayoutSpan self') = LayoutSpan self' -- | Update a (sub)tree to compute & cache final height. boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Double Double x boxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' @@ -269,11 +269,9 @@ boxHeight parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cell lowerSize (Left x) = Left $ lowerLength width x lowerSize (Right x) = Right x width = inline $ size parent -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' +boxHeight _ (LayoutInline val self' paging) = LayoutInline val self' paging +boxHeight _ (LayoutInline' val self' paging) = LayoutInline' val self' paging +boxHeight _ (LayoutSpan self') = LayoutSpan self' -- | Split a (sub)tree to fit within max-height. -- May take full page height into account. @@ -301,9 +299,9 @@ boxSplit maxheight pageheight (LayoutFlow val self childs) where start' = start + height (layoutGetBox child) inner _ [] = [] boxSplit _ _ self@(LayoutGrid _ _ _ _) = (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) = +boxSplit maxheight pageheight (LayoutInline a self b) = + boxSplit maxheight pageheight $ LayoutInline' a (layoutRich self) b +boxSplit maxheight pageheight (LayoutInline' a self paging) = case paginate paging { pageCurrentHeight = toEnum $ fromEnum maxheight, pageNextHeight = toEnum $ fromEnum pageheight @@ -311,8 +309,8 @@ boxSplit maxheight pageheight (LayoutInline' a b self paging c) = (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! + wrap self' = LayoutInline' a self' paging +boxSplit _ _ self@(LayoutSpan _) = (self, Nothing) -- Can't split! -- | Generate a list of pages from a node, splitting subtrees where necessary. boxPaginate pageheight node | (page, Just overflow) <- boxSplit pageheight pageheight node = @@ -332,13 +330,12 @@ boxPosition pos@(x, y) (LayoutGrid val self cells childs) = LayoutGrid (pos, val childs' = map recurse $ zip pos' childs recurse ((x', y'), child) = boxPosition (x + x', y + y') child pos' = gridPosition self cells -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... +boxPosition pos@(x, y) (LayoutInline val self paging) = + boxPosition pos $ LayoutInline' val (layoutRich self) paging +boxPosition pos@(x, y) (LayoutInline' val self paging) = + LayoutInline' (pos, val) (positionChildren pos self) paging +boxPosition pos (LayoutSpan self@(Fragment (a, b, c) d _ f g h)) = + LayoutSpan $ Fragment (a, b, (pos, c)) d [] f g h -- No children... -- | Compute sizes & position information for all nodes in the (sub)tree. boxLayout :: PropertyParser x => PaddedBox Double Double -> LayoutItem Length Length x -> Bool -> [LayoutItem Double Double ((Double, Double), x)] @@ -359,8 +356,8 @@ boxLayout parent self paginate = self9 -- | Compute a mapping from a layout tree indicating which glyphs for which fonts -- are required. -- Useful for assembling glyph atlases. -glyphsPerFont :: LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet +{- glyphsPerFont :: LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet glyphsPerFont (LayoutSpan _ font self) = (pattern font, fontSize font) `M.singleton` IS.fromList glyphs where glyphs = map fromEnum $ map Hb.codepoint $ map fst $ fragmentGlyphs self -glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node +glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node -} diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index f8abc41..c9249cb 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -9,6 +9,11 @@ import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands, parseUnorderedShorthand', parseUnorderedShorthand) import Stylist.Tree (StyleTree(..)) import Data.Text.ParagraphLayout (PageOptions(..)) +import Data.Text.ParagraphLayout.Rich (paragraphLineHeight, constructParagraph, + defaultParagraphOptions, textDirection, + defaultBoxOptions, LineHeight(..), + InnerNode(..), Box(..), RootNode(..)) +import Data.Text.Glyphize (Direction(..)) import Graphics.Layout.Box as B import Graphics.Layout @@ -20,6 +25,7 @@ import Graphics.Layout.Inline.CSS import Data.Maybe (isJust, fromMaybe) import qualified Data.HashMap.Lazy as HM +import Data.Char (isSpace) -- | Parsed CSS properties relevant to layout. data CSSBox a = CSSBox { @@ -47,6 +53,10 @@ data CSSBox a = CSSBox { -- | Parsed widows & orphans controlling pagination. pageOptions :: PageOptions } +-- | Accessor for inlineStyle's `textDirection` attribute. +direction CSSBox { inlineStyles = CSSInline _ opts } = textDirection opts +-- | Accessor for inlineStyle's options. +txtOpts CSSBox { inlineStyles = CSSInline _ opts } = opts -- | Possible values for CSS box-sizing. data BoxSizing = BorderBox | ContentBox -- | Empty border, to use as default value. @@ -114,6 +124,17 @@ instance PropertyParser a => PropertyParser (CSSBox a) where Just self { cssBox = box { padding = (padding box) { left = x } } } longhand _ self@CSSBox {cssBox = box} "padding-right" toks | Just x <- parseLength toks = Just self { cssBox = box { padding = (padding box) { right = x } } } + longhand _ self@CSSBox {cssBox = box} "padding-inline-start" toks + | Just x <- parseLength toks, DirLTR <- direction self = + Just self { cssBox = box { padding = (padding box) { left = x } } } + | Just x <- parseLength toks, DirRTL <- direction self = + Just self { cssBox = box { padding = (padding box) { right = x } } } + longhand _ self@CSSBox {cssBox = box} "padding-inline-end" toks + | Just x <- parseLength toks, DirLTR <- direction self = + Just self { cssBox = box { padding = (padding box) { right = x } } } + | Just x <- parseLength toks, DirRTL <- direction self = + Just self { cssBox = box { padding = (padding box) { left = x } } } + longhand _ self@CSSBox {cssBox = box} "border-top-width" toks | Just x <- parseLength toks = Just self { cssBox = box { border = (border box) { top = x } } } longhand _ self@CSSBox {cssBox = box} "border-bottom-width" toks | Just x <- parseLength toks = @@ -122,6 +143,37 @@ instance PropertyParser a => PropertyParser (CSSBox a) where Just self { cssBox = box { border = (border box) { left = x } } } longhand _ self@CSSBox {cssBox = box} "border-right-width" toks | Just x <- parseLength toks = Just self { cssBox = box { border = (border box) { right = x } } } + longhand p self "border-inline-start-color" toks + | DirLTR <- direction self = longhand p self "border-left-color" toks + | DirRTL <- direction self = longhand p self "border-right-color" toks + longhand p self "border-inline-start-width" toks + | DirLTR <- direction self = longhand p self "border-left-width" toks + | DirRTL <- direction self = longhand p self "border-right-width" toks + longhand p self "border-inline-start-style" toks + | DirLTR <- direction self = longhand p self "border-left-style" toks + | DirRTL <- direction self = longhand p self "border-right-style" toks + longhand p self "border-inline-end-color" toks + | DirLTR <- direction self = longhand p self "border-right-color" toks + | DirRTL <- direction self = longhand p self "border-left-color" toks + longhand p self "border-inline-end-width" toks + | DirLTR <- direction self = longhand p self "border-right-width" toks + | DirRTL <- direction self = longhand p self "border-left-width" toks + longhand p self "border-inline-end-style" toks + | DirLTR <- direction self = longhand p self "border-right-style" toks + | DirRTL <- direction self = longhand p self "border-left-style" toks + longhand p self "border-start-start-radius" t + | DirLTR <- direction self = longhand p self "border-top-left-radius" t + | DirRTL <- direction self = longhand p self "border-top-right-radius" t + longhand p self "border-start-end-radius" t + | DirLTR <- direction self = longhand p self "border-top-right-radius" t + | DirRTL <- direction self = longhand p self "border-top-left-radius" t + longhand p s "border-end-start-radius" t + | DirLTR <- direction s = longhand p s "border-bottom-left-radius" t + | DirRTL <- direction s = longhand p s "border-bottom-right-radius" t + longhand p s "border-end-end-radius" t + | DirLTR <- direction s = longhand p s "border-bottom-right-radius" t + | DirRTL <- direction s = longhand p s "border-bottom-left-radius" t + longhand _ self@CSSBox {cssBox = box} "margin-top" toks | Just x <- parseLength toks = Just self { cssBox = box { margin = (margin box) { top = x } } } longhand _ self@CSSBox {cssBox = box} "margin-bottom" toks | Just x <- parseLength toks = @@ -130,6 +182,31 @@ instance PropertyParser a => PropertyParser (CSSBox a) where Just self { cssBox = box { margin = (margin box) { left = x } } } longhand _ self@CSSBox {cssBox = box} "margin-right" toks | Just x <- parseLength toks = Just self { cssBox = box { margin = (margin box) { right = x } } } + longhand _ self@CSSBox {cssBox = box} "margin-inline-start" toks + | Just x <- parseLength toks, DirLTR <- direction self = + Just self { cssBox = box { margin = (margin box) { left = x } } } + | Just x <- parseLength toks, DirRTL <- direction self = + Just self { cssBox = box { margin = (margin box) { right = x } } } + longhand _ self@CSSBox {cssBox = box} "margin-inline-end" toks + | Just x <- parseLength toks, DirLTR <- direction self = + Just self { cssBox = box { margin = (margin box) { right = x } } } + | Just x <- parseLength toks, DirRTL <- direction self = + Just self { cssBox = box { margin = (margin box) { left = x } } } + + -- Placeholder implementations until vertical text is implemented. + longhand p self "padding-block-start" t = longhand p self "padding-top" t + longhand p self "padding-block-end" t = longhand p self "padding-bottom" t + longhand p self "margin-block-start" t = longhand p self "margin-top" t + longhand p self "margin-block-end" t = longhand p self "margin-bottom" t + longhand p self "border-block-start-color" toks = + longhand p self "border-top-color" toks + longhand p self "border-block-start-style" toks = + longhand p self "border-top-style" toks + longhand p self "border-block-start-width" toks = + longhand p self "border-top-width" toks + longhand p s "border-block-end-color" t = longhand p s "border-bottom-color" t + longhand p s "border-block-end-style" t = longhand p s "border-bottom-style" t + longhand p s "border-block-end-width" t = longhand p s "border-bottom-width" t longhand _ self@CSSBox {cssBox = box} "width" toks | Just x <- parseLength' toks = Just self { cssBox = box { size = (size box) { inline = x } } } @@ -260,6 +337,22 @@ instance PropertyParser a => PropertyParser (CSSBox a) where "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 = @@ -278,6 +371,36 @@ 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 + 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 @@ -298,7 +421,7 @@ finalizeCSS root parent self@StyleTree { style = self'@CSSBox { display = Grid, inner = val }, children = childs } = LayoutFlow val (finalizeBox self' font_) [ finalizeGrid (gridStyles self') font_ (map cellStyles $ map style childs) - (finalizeChilds root font_ (inner self') childs)] + (finalizeChilds root font_ self' childs)] where font_ = pattern2font (font self') (font' self') parent root finalizeCSS root parent self@StyleTree { @@ -319,26 +442,23 @@ finalizeCSS root parent self@StyleTree { 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_ val childs) + } = LayoutFlow val (finalizeBox self' font_) (finalizeChilds root font_ self' childs) where font_ = pattern2font (font self') (font' self') parent root finalizeCSS' sysfont self@StyleTree { style = self' } = finalizeCSS (pattern2font (font self') (font' self') sysfont sysfont) sysfont self -- | Desugar a sequence of child nodes, taking care to capture runs of inlines. -finalizeChilds :: PropertyParser x => Font' -> Font' -> x -> [StyleTree (CSSBox x)] -> - [LayoutItem Length Length x] +finalizeChilds :: PropertyParser x => Font' -> Font' -> CSSBox x -> + [StyleTree (CSSBox x)] -> [LayoutItem Length Length x] finalizeChilds root parent style' (StyleTree { style = CSSBox { display = None } }:childs) = finalizeChilds root parent style' childs finalizeChilds root parent style' childs@(child:childs') - | isInlineTree childs, Just self <- finalizeParagraph (flattenTree childs) parent = - -- 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 paging (repeat $ inherit style')] + | isInlineTree childs, Just self <- finalizeParagraph (flattenTree0 childs) = + [LayoutInline (inherit $ inner style') self paging] | (inlines@(_:_), blocks) <- spanInlines childs, - Just self <- finalizeParagraph (flattenTree inlines) parent = - LayoutInline (inherit style') parent self paging (repeat $ inherit style') : + Just self <- finalizeParagraph (flattenTree0 inlines) = + LayoutInline (inherit $ inner style') self paging : finalizeChilds root parent style' blocks | (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs = finalizeChilds root parent style' childs' -- Inline's all whitespace... @@ -355,11 +475,26 @@ finalizeChilds root parent style' childs@(child:childs') }:blocks)) -> let (inlines', blocks') = spanInlines tail in (inlines ++ inlines', blocks' ++ blocks) ret -> ret - flattenTree (StyleTree { children = child@(_:_) }:childs) = - flattenTree child `concatParagraph` flattenTree childs - flattenTree (child:childs) = - buildParagraph (inlineStyles $ style child) `concatParagraph` flattenTree childs - flattenTree [] = ParagraphBuilder "" [] + flattenTree0 childs = RootBox $ Box (map (flattenTree parent) childs) $ + flip applyFontInline parent $ txtOpts style' + flattenTree p StyleTree { children = child@(_:_), style = self } = + InlineBox (f, finalizeBox self f, inner self) + (Box (map (flattenTree f) child) + $ flip applyFontInline f $ txtOpts self) + defaultBoxOptions -- Fill in during layout. + where f = pattern2font (font self) (font' self) p root + flattenTree f StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _}} = + InlineBox (f, finalizeBox self f, inner self) + (Box [TextSequence (f, zero, inherit $ inner self) txt] $ + flip applyFontInline f $ txtOpts self) + defaultBoxOptions -- Fill in during layout. + finalizeParagraph (RootBox (Box [TextSequence _ txt] _)) + | Txt.all isSpace txt = Nothing -- Discard isolated whitespace. + finalizeParagraph tree = + Just $ constructParagraph "" tree "" defaultParagraphOptions { + paragraphLineHeight = Absolute $ toEnum $ fromEnum + (lineheight parent * hbUnit) + } finalizeChilds _ _ _ [] = [] -- | Desugar most units, possibly in reference to given font. diff --git a/Graphics/Layout/CSS/Font.hs b/Graphics/Layout/CSS/Font.hs index 037a20c..7a4db40 100644 --- a/Graphics/Layout/CSS/Font.hs +++ b/Graphics/Layout/CSS/Font.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- | Infrastructure for parsing & desugaring CSS properties related to fonts. -module Graphics.Layout.CSS.Font(Font'(..), placeholderFont, hbScale, hbUnit, +module Graphics.Layout.CSS.Font(Font'(..), placeholderFont, hbUnit, pattern2hbfont, pattern2font, CSSFont(..), variations') where import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize) @@ -22,9 +22,6 @@ import System.IO.Unsafe (unsafePerformIO) -- | zero'd `Font'` to serve as the root's parent in a font heirarchy. placeholderFont = Font' undefined [] (const 0) (const 0) 0 0 0 0 0 0 0 0 1 -- | Scale-factor for text-shaping APIs. -hbScale :: Font' -> Double -hbScale f = fontSize f*hbUnit --- | Magic number informing the value of `hbScale`. hbUnit = 64 :: Double -- | Convert from FontConfig query result to a Harfbuzz font. @@ -78,7 +75,7 @@ pattern2font pat styles parent root = Font' { Just (font:_, _) -> fontRenderPrepare' q font _ -> error "TODO: Set fallback font!" font' = pattern2hbfont font (round scale') $ variations' fontSize' styles - scale' = fontSize'*hbUnit + scale' = hbUnit -- Better way of handling this? -- | Parsed CSS font properties, excluding the FontConfig query. data CSSFont = CSSFont { diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs index 95aecea..472f86d 100644 --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -2,12 +2,11 @@ -- | 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, + inlineSize, inlineChildren, layoutSize, layoutChildren, positionChildren, fragmentSize, fragmentSize', fragmentPos) where -import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), - SpanLayout(..), Fragment(..), - ParagraphLayout(..), layoutPlain, Span(..)) +import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), + Fragment(..), ParagraphLayout(..), layoutRich) import Data.Text.ParagraphLayout.Rect (Rect(..), width, height, x_min, y_min) import Data.Text.Internal (Text(..)) import qualified Data.Text as Txt @@ -15,60 +14,68 @@ import Data.Char (isSpace) import Data.Int (Int32) import Graphics.Layout.Box (Size(..), CastDouble(..), fromDouble) -import Graphics.Layout.CSS.Font (Font', hbScale) +import Graphics.Layout.CSS.Font (Font', hbUnit) -- | Convert from Harfbuzz units to device pixels as a Double -hbScale' font = (/hbScale font) . fromIntegral +hbScale = (/hbUnit) . fromIntegral -- | Convert from Harfbuzz units to device pixels as a Double or Length. -c font = fromDouble . hbScale' font +c :: CastDouble a => Int32 -> a +c = fromDouble . hbScale -- | Compute minimum width for some richtext. -inlineMinWidth :: Font' -> Paragraph -> Double -inlineMinWidth font self = hbScale' font $ width $ layoutPlain' self 0 +inlineMinWidth :: Paragraph a -> Double +inlineMinWidth self = hbScale $ width $ layoutRich' self 0 -- | Compute minimum width & height for some richtext. -inlineMin :: (CastDouble x, CastDouble y) => Font' -> Paragraph -> Size x y -inlineMin font self = Size (c font $ width rect) (c font $ height rect) - where rect = layoutPlain' self 0 +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 :: Font' -> Paragraph -> Double -inlineNatWidth font self = hbScale' font $ width $ layoutPlain' self maxBound +inlineNatWidth :: Paragraph a -> Double +inlineNatWidth self = hbScale $ width $ layoutRich' self maxBound -- | Compute height for rich text at given width. -inlineHeight :: Font' -> Double -> Paragraph -> Double -inlineHeight font width self = - hbScale' font $ height $ layoutPlain' self $ round (hbScale font * 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) => Font' -> Paragraph -> Size x y -inlineSize font self = layoutSize font $ layoutPlain self +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 :: [x] -> Paragraph -> [(x, Fragment)] -inlineChildren vals self = layoutChildren vals $ layoutPlain self +inlineChildren :: Paragraph a -> [Fragment a] +inlineChildren self = layoutChildren $ layoutRich self -- | Retrieve a laid-out paragraph's rect & convert to CatTrap types. -layoutSize :: (CastDouble x, CastDouble y) => Font' -> ParagraphLayout -> Size x y -layoutSize font self = Size (c font $ width r) (c font $ height r) +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 :: [x] -> ParagraphLayout -> [(x, Fragment)] -layoutChildren vals self = zip vals $ concat $ map inner $ spanLayouts self - where inner (SpanLayout y) = y +layoutChildren :: ParagraphLayout a -> [Fragment a] +layoutChildren self = paragraphFragments self -- TODO: Extract tree... -- | Layout a paragraph at given width & retrieve resulting rect. -layoutPlain' :: Paragraph -> Int32 -> Rect Int32 -layoutPlain' (Paragraph a b c d) width = - paragraphRect $ layoutPlain $ Paragraph a b c d { paragraphMaxWidth = width } +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) => Font' -> Fragment -> Size x y -fragmentSize font self = Size (c font $ width r) (c font $ height r) +fragmentSize :: (CastDouble x, CastDouble y) => Fragment a -> Size x y +fragmentSize self = Size (c $ width r) (c $ height r) where r = fragmentRect self -- | Variant of `fragmentSize` asserting to the typesystem that both fields -- of the resulting `Size` are of the same type. -fragmentSize' :: CastDouble x => Font' -> Fragment -> Size x x +fragmentSize' :: CastDouble x => Fragment a -> Size x x fragmentSize' = fragmentSize -- Work around for typesystem. -- | Retrieve the position of a fragment. -fragmentPos :: Font' -> (Double, Double) -> Fragment -> (Double, Double) -fragmentPos font (x, y) self = - (x + hbScale' font (x_min r), y + hbScale' font (y_min r)) +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, (fragmentPos pos frag, c)) d [] f g h + | frag@(Fragment (a, b, c) d _ f g h) <- paragraphFragments self] + } diff --git a/Graphics/Layout/Inline/CSS.hs b/Graphics/Layout/Inline/CSS.hs index 175fd1a..759b6c3 100644 --- a/Graphics/Layout/Inline/CSS.hs +++ b/Graphics/Layout/Inline/CSS.hs @@ -1,60 +1,48 @@ {-# LANGUAGE OverloadedStrings #-} -- | Infrastructure for parsing & desugaring text related CSS properties. -module Graphics.Layout.Inline.CSS(CSSInline(..), ParagraphBuilder(..), - buildParagraph, concatParagraph, finalizeParagraph) where +module Graphics.Layout.Inline.CSS(CSSInline(..), applyFontInline) where import Data.CSS.Syntax.Tokens (Token(..)) import Stylist (PropertyParser(..)) -import qualified Data.Text.Lazy as Lz import qualified Data.Text as Txt import Data.Text.Internal (Text(..)) -import Data.Text.ParagraphLayout (Span(..), SpanOptions(..), LineHeight(..), - Paragraph(..), ParagraphOptions(..)) +import Data.Text.ParagraphLayout.Rich +import Data.Text.Glyphize (Direction(..)) -import Graphics.Layout.CSS.Font (Font'(..), hbScale) +import Graphics.Layout.CSS.Font (Font'(..), hbUnit) import Data.Char (isSpace) -- | Document text with Balkón styling options, CSS stylable. -data CSSInline = CSSInline Lz.Text SpanOptions +data CSSInline = CSSInline Txt.Text TextOptions instance PropertyParser CSSInline where - temp = CSSInline "" SpanOptions { - spanLanguage = "Zxx" - } + temp = CSSInline "" $ defaultTextOptions DirLTR inherit (CSSInline _ opts) = CSSInline "" opts + priority _ = ["direction"] -- To inform logical spacing in caller! + longhand _ (CSSInline _ o) "content" [Ident "initial"] = Just $ CSSInline "" o longhand _ (CSSInline _ opts) "content" toks | all isString toks = - Just $ CSSInline (Lz.concat [Lz.fromStrict x | String x <- toks]) opts + Just $ CSSInline (Txt.concat [x | String x <- toks]) opts where isString (String _) = True isString _ = False + longhand _ (CSSInline t o) "-argo-lang" [Ident kw] + | kw `elem` ["initial", "auto"] = Just $ CSSInline t o {textLanguage=""} longhand _ (CSSInline txt opts) "-argo-lang" [String x] = - Just $ CSSInline txt opts { spanLanguage = Txt.unpack x } + Just $ CSSInline txt opts { textLanguage = Txt.unpack x } + longhand _ (CSSInline txt opts) "direction" [Ident "ltr"] = + Just $ CSSInline txt opts { textDirection = DirLTR } + longhand _ (CSSInline txt opts) "direction" [Ident "rtl"] = + Just $ CSSInline txt opts { textDirection = DirRTL } + longhand _ (CSSInline txt opts) "direction" [Ident "initial"] = + Just $ CSSInline txt opts { textDirection = DirLTR } longhand _ _ _ _ = Nothing --- | Helper datastructure for concatenating CSSInlines. -data ParagraphBuilder = ParagraphBuilder Lz.Text [Span] - --- | Convert a CSSInline to a paragraph builder, with a span covering the entire text. -buildParagraph :: CSSInline -> ParagraphBuilder -buildParagraph (CSSInline txt opts) = - ParagraphBuilder txt [flip Span opts $ fromEnum $ Lz.length txt] --- | Concatenate two `ParagraphBuilder`s, adjusting the spans appropriately. -concatParagraph :: ParagraphBuilder -> ParagraphBuilder -> ParagraphBuilder -concatParagraph (ParagraphBuilder aTxt aOpts) (ParagraphBuilder bTxt bOps) = - ParagraphBuilder (aTxt `Lz.append` bTxt) - (aOpts ++ [Span (toEnum (fromEnum $ Lz.length aTxt) + off) opts - | Span off opts <- bOps]) --- | Convert a builder + font to a Balkón paragraph. -finalizeParagraph :: ParagraphBuilder -> Font' -> Maybe Paragraph -finalizeParagraph (ParagraphBuilder txt _) _ | Lz.all isSpace txt || Lz.null txt = Nothing -finalizeParagraph (ParagraphBuilder txt ops) font' = Just $ Paragraph txt' 0 ops pOps - where - Text txt' _ _ = Lz.toStrict txt - pOps = ParagraphOptions { - paragraphFont = hbFont font', - paragraphLineHeight = Absolute $ round (lineheight font' * hbScale font'), - -- This is what we're computing! Configure to give natural width. - paragraphMaxWidth = maxBound -- i.e. has all the space it needs... - } +applyFontInline :: TextOptions -> Font' -> TextOptions +applyFontInline opts font = opts { + textFont = hbFont font, + textLineHeight = Absolute $ toEnum $ fromEnum $ lineheight font * hbUnit + } + + diff --git a/cattrap.cabal b/cattrap.cabal index b9738c4..4e8af5d 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -34,7 +34,7 @@ library stylist-traits >= 0.1.3.0 && < 1, fontconfig-pure >= 0.2 && < 0.3, harfbuzz-pure >= 1.0.3.2 && < 1.1, bytestring, - balkon >= 0.2.1 && < 0.3, unordered-containers + balkon >= 1.0 && <2, unordered-containers -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wincomplete-patterns -- 2.30.2