From 9b5c291cc7b431ee86cce451855a8a8aaec83943 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 12 Mar 2023 16:46:43 +1300 Subject: [PATCH] Integrate inline layout! --- Graphics/Layout.hs | 55 ++++++++++++++++++++++++++++++--- Graphics/Layout/Box.hs | 8 +++++ Graphics/Layout/CSS.hs | 45 +++++++++++++++++++++++++-- Graphics/Layout/CSS/Internal.hs | 17 ++++++---- cattrap.cabal | 5 +-- 5 files changed, 115 insertions(+), 15 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index 44b1d2e..ebb625b 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -1,30 +1,50 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards #-} module Graphics.Layout where +import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), Fragment) + import Graphics.Layout.Box as B import Graphics.Layout.Grid as G import Graphics.Layout.Flow as F +import Graphics.Layout.Inline as I import Data.Maybe (fromMaybe) 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 Paragraph [x] -- Balkon holds children. + | LayoutSpan x Fragment -- More to come... +layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) => + LayoutItem m n x -> PaddedBox m n layoutGetBox (LayoutFlow _ ret _) = ret layoutGetBox (LayoutGrid _ self _) = zero { B.min = containerMin self, B.size = containerSize self, B.max = containerMax self } -setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child } +layoutGetBox (LayoutInline _ self _) = zero { + B.min = inlineSize self, B.size = inlineSize self, B.max = inlineSize self +} +layoutGetBox (LayoutSpan _ self) = zero { + B.min = fragmentSize self, B.size = fragmentSize self, B.max = fragmentSize self +} layoutGetChilds (LayoutFlow _ _ ret) = ret layoutGetChilds (LayoutGrid _ _ ret) = map snd ret +layoutGetChilds (LayoutSpan _ _) = [] +layoutGetChilds (LayoutInline _ self vals) = + map (uncurry LayoutSpan) $ inlineChildren vals self layoutGetInner (LayoutFlow ret _ _) = ret layoutGetInner (LayoutGrid ret _ _) = ret +layoutGetInner (LayoutInline ret _ _) = ret +layoutGetInner (LayoutSpan ret _) = ret + +setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child } -boxMinWidth :: Zero y => Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) +boxMinWidth :: (Zero y, CastDouble y) => + Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) boxMinWidth parent (LayoutFlow val self childs) = (min', LayoutFlow val self' childs') where self' = self {B.min = Size (Pixels min') (block $ B.min self) } @@ -52,7 +72,10 @@ boxMinWidth parent (LayoutGrid val self childs) = (GridItem {..}, _) <- childs]) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxNatWidth :: Zero y => Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) +boxMinWidth _ self@(LayoutInline _ self' _) = (inlineMinWidth self', self) +boxMinWidth _ self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self) +boxNatWidth :: (Zero y, CastDouble y) => + Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) boxNatWidth parent (LayoutFlow val self childs) = (size', LayoutFlow val self childs') -- NOTE: Need to preserve auto/percentage in actual width calculation. -- self' doesn't preserve this. CatTrap will need a decent refactor! @@ -84,6 +107,8 @@ boxNatWidth parent (LayoutGrid val self childs) = (GridItem {..}, _) <- childs]) parent zeroBox :: PaddedBox Double Double zeroBox = zero +boxNatWidth _ self@(LayoutInline _ self' _) = (inlineNatWidth self', self) +boxNatWidth _ self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self) boxMaxWidth :: PaddedBox a Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) boxMaxWidth parent (LayoutFlow val self childs) = (max', LayoutFlow val self' childs) where @@ -94,7 +119,9 @@ boxMaxWidth parent (LayoutGrid val self childs) = where self' = self { containerMax = Size (Pixels max') (block $ containerMax self) } (max', _) = gridMaxWidths parent self $ colBounds self -boxWidth :: Zero y => PaddedBox b Double -> LayoutItem y Length x -> +boxMaxWidth parent self@(LayoutInline _ _ _) = (B.inline $ B.max parent, self) +boxMaxWidth parent self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self) +boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x -> (Double, LayoutItem y Double x) boxWidth parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs') where @@ -129,6 +156,11 @@ boxWidth parent (LayoutGrid val self childs) = (size', LayoutGrid val self' chil } outerwidth = inline $ size parent (size', widths) = gridWidths parent self $ colBounds self +boxWidth parent (LayoutInline val (Paragraph a b c d) vals) = + (width, LayoutInline val (Paragraph a b c d { paragraphMaxWidth = round width }) vals) + where width = B.inline $ B.size parent +boxWidth parent (LayoutSpan val self') = + (B.inline $ fragmentSize' self', LayoutSpan val self') boxNatHeight :: Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x) boxNatHeight parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs') @@ -153,6 +185,8 @@ boxNatHeight parent (LayoutGrid val self childs) = cells = map setCellBox' $ zip childs' $ map fst childs childs' = map snd $ map (boxNatHeight width) $ map snd childs width = inline $ containerSize self +boxNatHeight parent self@(LayoutInline _ self' _) = (inlineHeight parent self', self) +boxNatHeight parent self@(LayoutSpan _ self') = (B.block $ fragmentSize' self', self) boxMinHeight :: Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x) boxMinHeight parent (LayoutFlow val self childs) = (min', LayoutFlow val self' childs') where @@ -179,6 +213,8 @@ boxMinHeight parent (LayoutGrid val self childs) = (min', LayoutGrid val self' c startCol = startCol cell, endCol = endCol cell, alignment = alignment cell } | (cell, _) <- childs] width = inline $ containerSize self +boxMinHeight parent self@(LayoutInline _ self' _) = (inlineHeight parent self', self) +boxMinHeight parent self@(LayoutSpan _ self') = (B.block $ fragmentSize' self', self) boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x) boxMaxHeight parent (LayoutFlow val self childs) = (max', LayoutFlow val self' childs') @@ -207,6 +243,10 @@ boxMaxHeight parent (LayoutGrid val self childs) = (max', LayoutGrid val self' c } (max', heights) = gridMaxHeights parent self $ rowBounds self width = inline $ size parent +boxMaxHeight parent (LayoutInline val self' vals) = + (inlineHeight (B.inline $ B.size parent) self', LayoutInline val self' vals) +boxMaxHeight parent (LayoutSpan val self') = + (B.block $ fragmentSize' self', LayoutSpan val self') boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> (Double, LayoutItem Double Double x) boxHeight parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs') @@ -238,6 +278,9 @@ boxHeight parent (LayoutGrid val self childs) = (size', LayoutGrid val self' chi lowerSize (Left x) = Left $ lowerLength width x lowerSize (Right x) = Right x width = inline $ size parent +boxHeight parent (LayoutInline val self' vals) = + (inlineHeight (B.inline $ B.size parent) self', LayoutInline val self' vals) +boxHeight _ (LayoutSpan val self') = (B.block $ fragmentSize' self', LayoutSpan val self') boxPosition :: (Double, Double) -> LayoutItem Double Double x -> LayoutItem Double Double ((Double, Double), x) @@ -251,6 +294,10 @@ 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 self vals) = + LayoutInline (pos, val) self $ map (\(x, y) -> (fragmentPos pos y, x)) $ + inlineChildren vals self +boxPosition pos (LayoutSpan val self) = LayoutSpan (pos, val) self -- No children... boxLayout :: PaddedBox Double Double -> LayoutItem Length Length x -> Bool -> LayoutItem Double Double ((Double, Double), x) boxLayout parent self paginate = self8 diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs index c337314..42bd22c 100644 --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -92,3 +92,11 @@ instance (Zero m, Zero n) => Zero (PaddedBox m n) where border = Border zero zero zero zero, margin = Border zero zero zero zero } + +class CastDouble a where + fromDouble :: Double -> a +fromIntegral' :: (Integral a, CastDouble b) => a -> b +fromIntegral' = fromDouble . fromIntegral + +instance CastDouble Double where fromDouble = id +instance CastDouble Length where fromDouble = Pixels diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index b0215d9..fc6d4c4 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -11,6 +11,7 @@ import Graphics.Layout import Graphics.Text.Font.Choose (Pattern(..)) import Graphics.Layout.CSS.Internal import Graphics.Layout.Grid.CSS +import Graphics.Layout.Inline.CSS data CSSBox a = CSSBox { display :: Display, @@ -21,12 +22,13 @@ data CSSBox a = CSSBox { inner :: a, gridStyles :: CSSGrid, cellStyles :: CSSCell, + inlineStyles :: CSSInline, captionBelow :: Bool } data BoxSizing = BorderBox | ContentBox noborder = Border (0,"px") (0,"px") (0,"px") (0,"px") -data Display = Block | Grid | Table | +data Display = Block | Grid | Inline | Table | TableRow | TableHeaderGroup | TableRowGroup | TableFooterGroup | TableCell | TableColumn | TableColumnGroup | TableCaption deriving Eq rowContainer CSSBox { display = d } = @@ -49,6 +51,7 @@ instance PropertyParser a => PropertyParser (CSSBox a) where inner = temp, gridStyles = temp, cellStyles = temp, + inlineStyles = temp, captionBelow = False } inherit parent = CSSBox { @@ -60,6 +63,7 @@ instance PropertyParser a => PropertyParser (CSSBox a) where inner = inherit $ inner parent, gridStyles = inherit $ gridStyles parent, cellStyles = inherit $ cellStyles parent, + inlineStyles = inherit $ inlineStyles parent, captionBelow = captionBelow parent } @@ -124,7 +128,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where Just self { display = TableColumn } longhand CSSBox { display = Table } self "display" [Ident "table-caption"] = Just self { display=TableCaption } - longhand _ self "display" [Ident "initial"] = Just self {display = Block } + longhand _ self "display" [Ident "inline"] = Just self { display = Inline } + longhand _ self "display" [Ident "initial"] = Just self { display = Block } longhand _ self "caption-side" [Ident "top"] = Just self { captionBelow = False } longhand _ self "caption-side" [Ident "bottom"] = Just self { captionBelow = True } @@ -139,6 +144,12 @@ instance PropertyParser a => PropertyParser (CSSBox a) where longhand a b c d | Just font <- longhand (font' a) (font' b) c d = Just b { font' = font } + longhand a b c d | Just inline' <- longhand (inlineStyles a) (inlineStyles b) c d = + Just b { inlineStyles = inline' } + longhand a b c d | Just grid' <- longhand (gridStyles a) (gridStyles b) c d = + 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 | Just inner' <- longhand (inner a) (inner b) c d = Just b { inner = inner' } @@ -164,7 +175,7 @@ finalizeCSS root parent self@StyleTree { finalizeCSS root parent self@StyleTree { style = self'@CSSBox { display = Table, captionBelow = True }, children = childs } = LayoutFlow (inner self') (finalizeBox self' font_) - (finalizeTable root font_ (inner self') childs: + (finalizeTable root font_ temp childs: [finalizeCSS root font_ child { style = child' { display = Block } } | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs]) where @@ -177,6 +188,34 @@ finalizeCSS root parent self@StyleTree { finalizeCSS' sysfont self@StyleTree { style = self' } = finalizeCSS (pattern2font (font self') (font' self') sysfont sysfont) sysfont self +finalizeChilds :: PropertyParser x => Font' -> Font' -> [StyleTree (CSSBox x)] -> + [LayoutItem Length Length x] +finalizeChilds root parent childs@(child:childs') + | isInlineTree childs = + -- FIXME propagate display properties, how to handle the hierarchy. + [LayoutInline temp (finalizeParagraph (flattenTree childs) parent) (repeat temp)] + | (inlines@(_:_), blocks) <- spanInlines childs = + LayoutInline temp (finalizeParagraph (flattenTree childs) parent) [] + :finalizeChilds root parent blocks + | otherwise = finalizeCSS root parent child : finalizeChilds root parent childs' + where + isInlineTree = all (isInlineTree . children) + isInlineTree0 StyleTree { style = CSSBox { display = Inline }, children = childs } = + isInlineTree childs + isInlineTree0 _ = False + spanInlines childs = case span isInlineTree0 childs of + (inlines, (StyleTree { + style = CSSBox { display = Inline }, children = tail + }: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 "" [] +finalizeChilds _ _ [] = [] + finalizeBox self@CSSBox { cssBox = box } font_ = mapY' (flip finalizeLength font_) $ mapX' (flip finalizeLength font_) box diff --git a/Graphics/Layout/CSS/Internal.hs b/Graphics/Layout/CSS/Internal.hs index a263792..8c5c438 100644 --- a/Graphics/Layout/CSS/Internal.hs +++ b/Graphics/Layout/CSS/Internal.hs @@ -64,6 +64,7 @@ finalizeLength (_,"max-content") _ = Preferred finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0 data Font' = Font' { + hbFont :: Maybe Font, -- Optional for sake of demo script, FIXME better solution? fontHeight :: Char -> Double, fontAdvance :: Char -> Double, fontSize :: Double, @@ -76,14 +77,16 @@ data Font' = Font' { vmin :: Double, scale :: Double } -placeholderFont = Font' (const 0) (const 0) 0 0 0 0 0 0 0 0 1 +placeholderFont = Font' Nothing (const 0) (const 0) 0 0 0 0 0 0 0 0 1 +ppem f = fontSize f/scale f -pattern2hbfont :: Pattern -> [Variation] -> Font -pattern2hbfont pat variations = createFontWithOptions options face +pattern2hbfont :: Pattern -> Word -> [Variation] -> Font +pattern2hbfont pat ppem variations = createFontWithOptions options face where bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat - options = foldl value2opt defaultFontOptions $ normalizePattern pat + options = foldl value2opt defaultFontOptions { optionPPEm = Just (ppem, ppem) } $ + normalizePattern pat value2opt opts ("slant", (_, ValueInt x):_) = opts { optionSynthSlant = Just $ realToFrac x @@ -93,6 +96,7 @@ pattern2hbfont pat variations = createFontWithOptions options face pattern2font :: Pattern -> CSSFont -> Font' -> Font' -> Font' pattern2font pat styles parent root = Font' { + hbFont = Just font', fontHeight = height' . fontGlyphExtents font' . fontGlyph', fontAdvance = fromIntegral . fontGlyphHAdvance font' . fontGlyph', fontSize = fontSize', @@ -109,12 +113,13 @@ pattern2font pat styles parent root = Font' { height' (Just x) = fromIntegral $ HB.height x height' Nothing = fontSize' lineheight' | snd (cssLineheight styles) == "normal", - Just extents <- fontHExtents font' = fromIntegral $ lineGap extents + Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/ppem | otherwise = lowerLength' (cssLineheight styles) parent fontSize' = lowerLength' (cssFontSize styles) parent lowerLength' a = lowerLength (fontSize parent) . finalizeLength a fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing - font' = pattern2hbfont pat $ variations' fontSize' styles + font' = pattern2hbfont pat (round ppem) $ variations' fontSize' styles + ppem = fontSize'/scale root data CSSFont = CSSFont { cssFontSize :: Unitted, diff --git a/cattrap.cabal b/cattrap.cabal index 2b3a8c4..9802aa2 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -19,10 +19,11 @@ cabal-version: >=1.10 library exposed-modules: Graphics.Layout, Graphics.Layout.CSS, Graphics.Layout.Flow, Graphics.Layout.Grid, Graphics.Layout.Box, Graphics.Layout.Arithmetic, - Graphics.Layout.CSS.Internal, Graphics.Layout.Grid.CSS + Graphics.Layout.CSS.Internal, Graphics.Layout.Grid.CSS, + Graphics.Layout.Inline, Graphics.Layout.Inline.CSS -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.16, css-syntax, scientific, text, stylist-traits, fontconfig-pure, harfbuzz-pure, bytestring + build-depends: base >=4.12 && <4.16, css-syntax, scientific, text, stylist-traits, fontconfig-pure, harfbuzz-pure, bytestring, balkon -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wincomplete-patterns -- 2.30.2