From 5c3e14af12e9a5a7b7172c904365e9326fdb74d6 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 27 Oct 2023 13:35:30 +1300 Subject: [PATCH] Implement more of layout --- Graphics/Layout/CSS.hs | 66 +++++++++++++++++++++++++++++++----- Graphics/Layout/CSS/Parse.hs | 30 ++++++++++++---- 2 files changed, 82 insertions(+), 14 deletions(-) diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index cf187d5..f21b654 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -73,7 +73,7 @@ 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') +finalizeChilds root parent style' childs@(child:_) | isInlineTree childs, Just self <- finalizeParagraph (flattenTree0 childs) = [LayoutInline (inherit $ inner' parent style') self paging] | (inlines@(_:_), blocks) <- spanInlines childs, @@ -82,7 +82,6 @@ finalizeChilds root parent style' childs@(child:childs') 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 @@ -118,7 +117,23 @@ finalizeChilds root parent style' childs@(child:childs') finalizeParagraph tree = Just $ constructParagraph "" tree "" $ paragraphOptions style' enumerate = zip $ enumFrom 0 -finalizeChilds _ _ _ [] = [] +finalizeChilds root parent style' childs + | (_:_) <- table = finalizeTable root parent temp table: + finalizeChilds root parent style' rest + | (child:childs') <- childs = finalizeCSS root parent child: + finalizeChilds root parent style' childs' + | otherwise = [] + where + (table, rest) = span isTable childs + isTable (StyleTree CSSBox { display = TableRow } _) = True + isTable (StyleTree CSSBox { display = TableHeaderGroup } _) = True + isTable (StyleTree CSSBox { display = TableRowGroup } _) = True + isTable (StyleTree CSSBox { display = TableFooterGroup } _) = True + isTable (StyleTree CSSBox { display = TableCell } _) = True + isTable (StyleTree CSSBox { display = TableColumn } _) = True + isTable (StyleTree CSSBox { display = TableColumnGroup } _) = True + -- Treat TableCaption as a block element! + isTable _ = False -- | Desugar most units, possibly in reference to given font. finalizeBox self@CSSBox { cssBox = box } font_ = @@ -126,7 +141,7 @@ finalizeBox self@CSSBox { cssBox = box } font_ = -- | (Unused, incomplete) Desugar a styletree of table elements to a grid layout. finalizeTable root parent val childs = LayoutFlow val lengthBox [] -- Placeholder! -{- finalizeTable root parent val childs = LayoutGrid val grid $ zip cells' childs' +{-finalizeTable root parent val childs = LayoutGrid val grid $ zip cells' childs' where -- FIXME? How to handle non-table items in
? grid = Grid { rows = take width $ repeat ("", (0,"auto")), @@ -141,12 +156,47 @@ finalizeTable root parent val childs = LayoutFlow val lengthBox [] -- Placeholde containerMax = Size Auto Auto } cells' = adjustWidths cells - + (cells, width, height) = lowerCells childs lowerCells (StyleTree self@CSSBox { display = TableRow } cells:rest) = (row:rows, max rowwidth width', succ height) where - (row, rowwidth) = lowerRow cells 0 -- FIXME: How to dodge colspans? + (row, rowwidth) = lowerRow cells 0 -- FIXME: How to dodge rowspans? + (rows, width', height') = lowerCells rest + lowerCells (StyleTree CSSBox { display = TableHeaderGroup } childs:rest) = + -- Ignore table-header-group styles for now... + -- Though it'd be nice for this to impact pagination... + lowerCells (childs ++ rest) + lowerCells (StyleTree CSSBox { display = TableFooterGroup } childs:rest) = + lowerCells (childs ++ rest) -- As per TableHeaderGroup + lowerCells (StyleTree CSSBox { display = TableRowGroup } childs:rest) = + lowerCells (childs ++ rest) -- As per TableHeaderGroup + lowerCells (StyleTree CSSBox { display = TableColumnGroup } _:rest) = + lowerCells rest -- It'd be nice to allow styling based on this... + lowerCells (StyleTree CSSBox { display = TableColumn } _:rest) = + lowerCells rest -- As per TableColumnGroup, should be contained within it. + lowerCells (StyleTree CSSBox { display = TableSummary } _:rest) = + lowerCells rest -- Handled by callers! + lowerCells [] = ([], 0, 0) + lowerCells items = (row:rows, max rowwidth width', succ height) + where + (cells, rest) = break isRowGroup items + (row, rowwidth) = lowerRow cells 0 -- FIXME: How to dodge rowspans? (rows, width', height') = lowerCells rest - lowerCells (StyleTree self@CSSBox { display = TableHeaderGroup } childs ) = - -} + isRowGroup (StyleTree CSSBox { display = TableRow } _) = True + isRowGroup (StyleTree CSSBox { display = TableHeaderGroup } _) = True + isRowGroup (StyleTree CSSBox { display = TableFooterGroup } _) = True + isRowGroup (StyleTree CSSBox { display = TableRowGroup } _) = True + isRowGroup _ = False + + lowerRow (StyleTree self'@CSSBox { display = TableCell } childs:rest) ix = + (cell:cells, width) + where + (cells, width) = lowerRow rest end + end = ix + colspan self' + cell = (GridItem' ix end _ _ _ `Size` _, + finalizeCSS __ $ StyleTree self' { display = Block } childs) + lowerRow (self:rest) ix = (cell:cells, width) + where + (cells, width) = lowerRow rest $ succ ix + cell = (GridItem' ix (succ ix) _ _ _ `Size` _, finalizeCSS __ self)-} diff --git a/Graphics/Layout/CSS/Parse.hs b/Graphics/Layout/CSS/Parse.hs index adf993c..dc96f52 100644 --- a/Graphics/Layout/CSS/Parse.hs +++ b/Graphics/Layout/CSS/Parse.hs @@ -17,8 +17,9 @@ import Graphics.Layout.Grid.CSS (CSSGrid(..), CSSCell(..), Placement(..)) import Graphics.Layout.Inline.CSS (CSSInline(..)) import Data.Maybe (isJust, fromMaybe) +import Text.Read (readMaybe) import qualified Data.HashMap.Lazy as HM -import Data.Text (Text) +import Data.Text (Text, unpack) import Debug.Trace (trace) -- For debug warnings. -- | Parsed CSS properties relevant to layout. @@ -51,7 +52,11 @@ data CSSBox a = CSSBox { -- | Parsed widows & orphans controlling pagination. pageOptions :: PageOptions, -- | Parsed text-alignment & other options which applies per-paragraph. - paragraphOptions :: ParagraphOptions + paragraphOptions :: ParagraphOptions, + -- | HTML rowspan attribute + rowspan :: Integer, + -- | HTML colspan attribute + colspan :: Integer } -- | Accessor for inlineStyle's `textDirection` attribute. direction CSSBox { inlineStyles = CSSInline _ opts _ } = textDirection opts @@ -96,7 +101,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where pageOptions = PageOptions 0 0 2 2, paragraphOptions = defaultParagraphOptions { paragraphAlignment = AlignStart - } + }, + rowspan = 1, colspan = 1 } inherit parent = CSSBox { boxSizing = boxSizing parent, @@ -112,7 +118,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where inlineStyles = inherit $ inlineStyles parent, captionBelow = captionBelow parent, pageOptions = pageOptions parent, - paragraphOptions = paragraphOptions parent + paragraphOptions = paragraphOptions parent, + rowspan = 1, colspan = 1 } priority self = concat [x font, x font', x gridStyles, x cellStyles, x inner] where x getter = priority $ getter self @@ -233,7 +240,7 @@ instance PropertyParser a => PropertyParser (CSSBox a) where longhand _ self "display" [Ident "block"] = Just self { display = Block } longhand _ self "display" [Ident "none"] = Just self { display = None } longhand _ self "display" [Ident "grid"] = Just self { display = Grid } - {-longhand _ self "display" [Ident "table"] = Just self { display = Table } + longhand _ self "display" [Ident "table"] = Just self { display = Table } longhand CSSBox { display = Table } self "display" [Ident "table-row-group"] = Just self { display=TableRowGroup } longhand CSSBox { display = Table } self "display" [Ident "table-header-group"] = @@ -249,10 +256,21 @@ instance PropertyParser a => PropertyParser (CSSBox a) where longhand CSSBox { display = TableColumnGroup } self "display" [Ident "table-column"] = Just self { display = TableColumn } longhand CSSBox { display = Table } self "display" [Ident "table-caption"] = - Just self { display=TableCaption } -} + Just self { display=TableCaption } longhand _ self "display" [Ident "inline"] = Just self { display = Inline } longhand _ self "display" [Ident "initial"] = Just self { display = Inline } + longhand _ self "-argo-rowspan" [Ident "initial"] = Just self { rowspan = 1 } + longhand _ self "-argo-rowspan" [String x] + | Just y <- readMaybe $ unpack x, y >= 1 = Just self { rowspan = y } + longhand _ self "-argo-rowspan" [Number _ (NVInteger x)] + | x >= 1 = Just self { rowspan = x } + longhand _ self "-argo-colspan" [Ident "initial"] = Just self { colspan = 1 } + longhand _ self "-argo-colspan" [String x] + | Just y <- readMaybe $ unpack x, y >= 1 = Just self { colspan = y } + longhand _ self "-argo-colspan" [Number _ (NVInteger x)] + | x >= 1 = Just self { colspan = x } + longhand _ self "caption-side" [Ident "top"] = Just self { captionBelow = False } longhand _ self "caption-side" [Ident "bottom"] = Just self { captionBelow = True } longhand _ self "caption-side" [Ident "initial"] = Just self {captionBelow = False} -- 2.30.2