cattrap 0.3.0.0 → 0.3.1.0

raw patch · 11 files changed

+534/−91 lines, 11 filesdep +data-array-bytedep ~balkondep ~harfbuzz-purePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-array-byte

Dependency ranges changed: balkon, harfbuzz-pure

API changes (from Hackage documentation)

Files

• Graphics/Layout.hs +34/−8
• Graphics/Layout/Box.hs +2/−0
• Graphics/Layout/CSS.hs +164/−36
• Graphics/Layout/CSS/Length.hs +6/−3
• Graphics/Layout/CSS/Parse.hs +38/−36
• Graphics/Layout/Grid.hs +1/−1
• Graphics/Layout/Grid/Table.hs +131/−0
• Graphics/Layout/Inline.hs +14/−1
• Graphics/Layout/Inline/CSS.hs +30/−2
• cattrap.cabal +6/−4
• test/Test.hs +108/−0

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards, StandaloneDeriving #-} -- | Generic layout logic, handling a hierarchy of varying formulas. -- Unless callers have more specific needs they probably wish to use this abstraction. -- Attempts to follow the CSS specs.@@ -8,7 +8,8 @@         layoutGetBox, layoutGetChilds, layoutGetInner,         boxMinWidth, boxMaxWidth, boxNatWidth, boxWidth,         boxNatHeight, boxMinHeight, boxMaxHeight, boxHeight,-        boxSplit, boxPaginate, boxPosition, boxLayout{-, glyphsPerFont-}) where+        boxSplit, boxPaginate, boxPosition, boxLayout,+        glyphs, codepoints, fragmentFont, {-, glyphsPerFont-}) where  import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),                                 ParagraphLayout(..), layoutRich)@@ -21,7 +22,7 @@ import Graphics.Layout.Grid as G import Graphics.Layout.Flow as F import Graphics.Layout.Inline as I-import Graphics.Layout.CSS.Font (Font')+import Graphics.Layout.CSS.Font (Font'(..))  import Data.Maybe (fromMaybe) @@ -31,6 +32,11 @@ import qualified Data.Text.Glyphize as Hb import Graphics.Text.Font.Choose (Pattern) +-- For comparisons+import Data.Array.Byte (ByteArray(..))+import Data.Text.Array (Array(..))+import Unsafe.Coerce (unsafeCoerce)+ -- | Additional data routed through Balkon. type UserData m n x = ((Font', Int), PaddedBox m n, x) @@ -51,6 +57,7 @@     | LayoutConst x (PaddedBox m n) [LayoutItem m n x]     -- | Children of a `LayoutInline` or `LayoutInline'`.     | LayoutSpan (FragmentTree (UserData m n x))+    deriving (Show, Eq) -- | An empty box. nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x nullLayout = LayoutFlow temp zero []@@ -94,6 +101,8 @@ layoutGetInner (LayoutConst ret _ _) = ret layoutGetInner (LayoutSpan x) = treeInner x +fragmentFont x = let (ret, _, _) = treeInner' x in ret+ -- | map-ready wrapper around `setCellBox` sourcing from a child node. setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child @@ -394,11 +403,28 @@ -- | 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 (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 :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq z) =>+        LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet+glyphsPerFont (LayoutSpan self) | (_:_) <- glyphs =+        (pattern font, fontSize font) `M.singleton` IS.fromList glyphs+    | otherwise = M.empty+  where+    glyphs = map fromEnum $ codepoints self+    (font, _) = fragmentFont self+glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node  parMap' :: NFData b => (a -> b) -> [a] -> [b] parMap' = parMap rdeepseq++------+--- Orphan typeclass instances+------++instance Show (Paragraph x) where+    show (Paragraph arr _ _ _) = show $ asBA arr+deriving instance Show PageOptions+instance Eq (Paragraph x) where+    Paragraph a _ _ _ == Paragraph b _ _ _ = asBA a  == asBA b+deriving instance Eq PageOptions++asBA = unsafeCoerce :: Array -> ByteArray

@@ -164,6 +164,8 @@         border = Border zero zero zero zero,         margin = Border zero zero zero zero     }+instance (Zero m, Zero n) => Zero (Border m n) where+    zero = Border zero zero zero zero  class CastDouble a where     -- | Convert a double to a double or length.

@@ -17,6 +17,8 @@ import Graphics.Layout.CSS.Length import Graphics.Layout.CSS.Font import Graphics.Layout.Grid.CSS+import Graphics.Layout.Grid+import Graphics.Layout.Grid.Table import Graphics.Layout.Inline.CSS  import Data.Char (isSpace)@@ -44,17 +46,24 @@   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' font_ self') (finalizeBox self' font_)+        style = self'@CSSBox {+            display = Table, tableOptions = opts@TableOptions {captionBelow=False}+        },+        children = childs+    } = LayoutFlow (inner' font_ self')+        (finalizeBox (collapseTBorders' self') font_)         ([finalizeCSS root font_ child { style = child' { display = Block } }             | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs] ++-        [finalizeTable root font_ (inner self') childs])+        [finalizeTable root font_ (inner self') opts 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' font_ self') (finalizeBox self' font_)-        (finalizeTable root font_ temp childs:+        style = self'@CSSBox {+            display = Table, tableOptions = opts@TableOptions {captionBelow=True}+        }, children = childs+    } = LayoutFlow (inner' font_ self')+        (finalizeBox (collapseTBorders' self') font_)+        (finalizeTable root font_ temp opts childs:         [finalizeCSS root font_ child { style = child' { display = Block } }             | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs])   where@@ -73,7 +82,7 @@         [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 +91,6 @@                 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@@ -102,7 +110,7 @@                 $ flip applyFontInline parent $ txtOpts style'         | otherwise = RootBox $ Box (map (flattenTree parent) $ enumerate childs)             $ flip applyFontInline parent $ txtOpts style'-    flattenTree p (i, StyleTree { children = child@(_:_), style = self }) =+    flattenTree p (i, StyleTree self child@(_:_)) =         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 _ _}})@@ -111,42 +119,162 @@     buildInline f i self childs =         InlineBox ((f, i), finalizeBox self f, inner' parent self)                 (Box childs' $ flip applyFontInline f $ txtOpts self)-                defaultBoxOptions -- Fill in during layout.+                $ resolveBoxOpts f (tableOptions self)       where childs' = applyBidi (inlineStyles self) childs     finalizeParagraph (RootBox (Box [TextSequence _ txt] _))         | Txt.all isSpace txt = Nothing -- Discard isolated whitespace.     finalizeParagraph tree =         Just $ constructParagraph "" tree "" $ paragraphOptions style'     enumerate = zip $ enumFrom 0-finalizeChilds _ _ _ [] = []+finalizeChilds root parent style'@CSSBox { tableOptions = tOpts } childs+    | (_:_) <- table = finalizeTable root parent temp tOpts 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_ =     mapY' (flip finalizeLength font_) $ mapX' (flip finalizeLength font_) box --- | (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'-  where -- FIXME? How to handle non-table items in <table>?-    grid = Grid {-        rows = take width $ repeat ("", (0,"auto")),-        rowBounds = [],-        subgridRows = 0,-        columns = take height $ repeat ("", (0,"auto")),-        colBounds = [],-        subgridCols = 0,-        gap = Size (0,"px") (0,"px"), -- FIXME where to get this from?-        containerSize = Size Auto Auto, -- Proper size is set on parent.-        containerMin = Size Auto Auto,-        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)+-- | Desugar a styletree of table elements to a grid layout.+finalizeTable root parent val opts childs = LayoutGrid val grid cells' childs'+  where+    grid = Track {+        cells = replicate width $ Left Auto,+        gap = hGap,+        trackMins = [], trackNats = []+      } `Size` Track {+        cells = replicate height $  Left Auto,+        gap = yGap,+        trackMins = [], trackNats = []+      }+    (cells', childs') = unzip (decor ++ cells)+    (hGap, yGap) = finalizeGap opts parent++    (cells, width, height) = lowerCells childs 0 emptyRow+    decor = decorateRow childs width 0 ++ decorateCol childs height 0+    lowerCells (StyleTree self@CSSBox { display = TableRow } cells:rest) h x =+        (row ++ rows, Prelude.max rowwidth width', height')       where-        (row, rowwidth) = lowerRow cells 0 -- FIXME: How to dodge colspans?-        (rows, width', height') = lowerCells rest-    lowerCells (StyleTree self@CSSBox { display = TableHeaderGroup } childs ) =-        -}+        (row, rowwidth, x') = lowerRow cells 0 h x+        (rows, width', height') = lowerCells rest (succ h) $ commitRow x'+    lowerCells (StyleTree CSSBox { display = TableHeaderGroup } childs:rest) h x =+        -- Ignore table-header-group styles for now...+        -- Though it'd be nice for this to impact pagination...+        lowerCells (childs ++ rest) h x+    lowerCells (StyleTree CSSBox { display = TableFooterGroup } childs:rest) h x =+        lowerCells (childs ++ rest) h x -- As per TableHeaderGroup+    lowerCells (StyleTree CSSBox { display = TableRowGroup } childs:rest) h x =+        lowerCells (childs ++ rest) h x -- As per TableHeaderGroup+    lowerCells (StyleTree CSSBox { display = TableColumnGroup } _:rest) h x =+        lowerCells rest h x -- It'd be nice to allow styling based on this...+    lowerCells (StyleTree CSSBox { display = TableColumn } _:rest) h x =+        lowerCells rest h x -- As per TableColumnGroup, should be contained within.+    lowerCells (StyleTree CSSBox { display = TableCaption } _:rest) h x =+        lowerCells rest h x -- Handled by callers!+    lowerCells [] h _ = ([], 0, h)+    lowerCells items h x = (row ++ rows, Prelude.max rowwidth width', height')+      where+        (cells, rest) = break isRowGroup items+        (row, rowwidth, x') = lowerRow cells 0 h x+        (rows, width', height') = lowerCells rest (succ h) $ commitRow x'++    lowerRow (StyleTree self@CSSBox {+            display = TableCell, tableOptions = self' } childs:rest) ix row x =+        (cell:cells, width, x')+      where+        (cells, width, x') = lowerRow rest end row $+            insertCell start (colspan self') (rowspan self') x+        start = allocCol ix x+        end = start + colspan self'+        cell = (GridItem start end Start 0 0+                `Size` GridItem row (row + rowspan self') valign 0 0,+            finalizeCSS root parent $ StyleTree self { display = Block } childs)+        valign = finalizeVAlign self'+        halign = finalizeHAlign (paragraphOptions self) (direction self)+    lowerRow (self:rest) ix row x = (cell:cells, width, x')+      where+        ix' = allocCol ix x+        (cells, width, x') = lowerRow rest (succ ix') row $ insertCell ix' 1 1 x+        cell = (GridItem ix' (succ ix') Start 0 0+                `Size` GridItem row (succ row) Start 0 0,+            finalizeCSS root parent self {+                style = (style self) {+                    cssBox = collapseBorders opts $ cssBox $ style self+                }+            })+    lowerRow [] ix _ x = ([], ix, x)++    decorateRow (StyleTree self@CSSBox { display = TableRow } _:rest) w row =+        buildDecor self 0 w row 1:decorateRow rest w (succ row)+    decorateRow (StyleTree self@CSSBox { display = d } childs:rest) w row+        | d `elem` [TableHeaderGroup, TableFooterGroup, TableRowGroup] =+            buildDecor self 0 w row (countRows childs):+                decorateRow (childs ++ rest) w (row + countRows childs)+        | d `elem` [TableCaption, TableColumn, TableColumnGroup] =+            decorateRow rest w row+        | otherwise = decorateRow (dropWhile (not . isRowGroup) rest) w$succ row+    decorateRow [] _ _ = []+    decorateCol (StyleTree self@CSSBox { display = TableColumn } _:rest) h col =+        buildDecor self col 1 0 h:decorateCol rest h (succ col)+    decorateCol (StyleTree self@CSSBox { display = TableColumnGroup } childs:rest)+        h col = buildDecor self col (countCols' childs self) 0 h:+            decorateCol (childs ++ rest) h (col + countCols' childs self)+    decorateCol (_:rest) h col = decorateCol rest h col+    decorateCol [] _ _ = []++    countRows (StyleTree CSSBox { display = TableRow } _:rest) =+        succ $ countRows rest+    countRows (StyleTree CSSBox { display = d } childs:rest)+        | d `elem` [TableHeaderGroup, TableFooterGroup, TableRowGroup] =+            countRows childs + countRows rest+        | d `elem` [TableCaption, TableColumn, TableColumnGroup] = countRows rest+        | otherwise = succ $ countRows $ dropWhile (not . isRowGroup) rest+    countRows [] = 0+    countCols' cols@(_:_) _ = countCols cols+    countCols' _ CSSBox { tableOptions = TableOptions { colspan = x } } = x+    countCols (StyleTree CSSBox {+            display = TableColumn,+            tableOptions = TableOptions { colspan = x }+        } _:rest) = x + countCols rest+    countCols (StyleTree CSSBox {+            display = TableColumnGroup,+            tableOptions = TableOptions { colspan = x }+        } []:rest) = x + countCols rest+    countCols (StyleTree CSSBox { display = TableColumnGroup } childs:rest) =+        countCols childs + countCols rest+    countCols (_:rest) = countCols rest+    countCols [] = 0++    buildDecor self col colspan row rowspan =+        (GridItem col (col + colspan) Start 0 0 `Size`+            GridItem row (row + rowspan) Start 0 0,+            finalizeCSS root parent $ StyleTree self {+                display = Block, cssBox = collapseBorders opts $ cssBox self+            } [])++    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 (StyleTree CSSBox { display = TableCaption } _) = True+    isRowGroup (StyleTree CSSBox { display = TableColumn } _) = True+    isRowGroup (StyleTree CSSBox { display = TableColumnGroup } _) = True+    isRowGroup _ = False++collapseTBorders' :: CSSBox x -> CSSBox x+collapseTBorders' self = self {+    cssBox = collapseTBorders (tableOptions self) (cssBox self)+  }

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -- | Infrastructure for parsing & desugaring length units & keywords, -- in reference to the selected font. module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength', units,@@ -17,6 +17,7 @@ -- The unit may alternately represent a keyword, in which case the number is -- ignored & typically set to 0. type Unitted = (Double, Txt.Text)+instance Zero Unitted where zero = (0,"px") -- | The CSS `auto` keyword. auto :: Unitted auto = (0,"auto")@@ -59,8 +60,8 @@ finalizeLength (x,"vb") f = Pixels $ x*vh f -- TODO: Support vertical text finalizeLength (x,"vw") f = Pixels $ x*vw f finalizeLength (x,"vi") f = Pixels $ x*vw f -- TODO: Support vertical text-finalizeLength (x,"vmax") f = Percent $ x*vmax f-finalizeLength (x,"vmin") f = Percent $ x*vmin f+finalizeLength (x,"vmax") f = Pixels $ x*vmax f+finalizeLength (x,"vmin") f = Pixels $ x*vmin f finalizeLength (x,"px") f = Pixels $ x*scale f finalizeLength (x,"cm") f = Pixels $ x*scale f*96/2.54 finalizeLength (x,"in") f = Pixels $ x*96*scale f@@ -119,3 +120,5 @@  instance Eq Font' where     a == b = pattern a == pattern b+instance Show Font' where+    show a = show $ pattern a

@@ -14,11 +14,13 @@ 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.Grid.Table (TableOptions) 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.@@ -46,12 +48,13 @@     cellStyles :: CSSCell,     -- | inline-related CSS properties.     inlineStyles :: CSSInline,-    -- | Parsed CSS caption-side.-    captionBelow :: Bool,     -- | Parsed widows & orphans controlling pagination.     pageOptions :: PageOptions,     -- | Parsed text-alignment & other options which applies per-paragraph.-    paragraphOptions :: ParagraphOptions+    paragraphOptions :: ParagraphOptions,+    -- | (Semi-)parsed CSS properties & HTML attributes relating to laying out+    -- HTML table elements.+    tableOptions :: TableOptions } -- | Accessor for inlineStyle's `textDirection` attribute. direction CSSBox { inlineStyles = CSSInline _ opts _ } = textDirection opts@@ -92,11 +95,11 @@         gridStyles = temp,         cellStyles = temp,         inlineStyles = temp,-        captionBelow = False,         pageOptions = PageOptions 0 0 2 2,         paragraphOptions = defaultParagraphOptions {             paragraphAlignment = AlignStart-        }+        },+        tableOptions = temp       }     inherit parent = CSSBox {         boxSizing = boxSizing parent,@@ -110,9 +113,9 @@         gridStyles = inherit $ gridStyles parent,         cellStyles = inherit $ cellStyles parent,         inlineStyles = inherit $ inlineStyles parent,-        captionBelow = captionBelow parent,         pageOptions = pageOptions parent,-        paragraphOptions = paragraphOptions parent+        paragraphOptions = paragraphOptions parent,+        tableOptions = inherit $ tableOptions parent       }     priority self = concat [x font, x font', x gridStyles, x cellStyles, x inner]       where x getter = priority $ getter self@@ -233,7 +236,7 @@     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,19 +252,37 @@     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 "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}-     longhand _ self "orphans" [Number _ (NVInteger x)] =         Just self { pageOptions = (pageOptions self) { pageOrphans = fromInteger x } }     longhand _ self "widows" [Number _ (NVInteger x)] =         Just self { pageOptions = (pageOptions self) { pageWidows = fromInteger x } } +    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "initial"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "start"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "end"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignEnd } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "left"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignLeft } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "right"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignRight } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "center"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignCentreH } }+    -- text-align: justify is unimplemented.+    longhand p self@CSSBox { paragraphOptions = o } "text-align"+            [Ident "match-parent"] = case paragraphAlignment$paragraphOptions p of+        AlignStart | DirLTR <- direction p -> ret AlignLeft+        AlignStart | DirRTL <- direction p -> ret AlignRight+        AlignEnd | DirLTR <- direction p -> ret AlignRight+        AlignEnd | DirRTL <- direction p -> ret AlignLeft+        x -> ret x+      where ret x = Just self { paragraphOptions = o { paragraphAlignment = x } }+     longhand a b c d | Just x <- longhand (font a) (font b) c d,         Just y <- longhand (font' a) (font' b) c d =             Just b { font = x, font' = y } -- Those properties can overlap!@@ -277,6 +298,8 @@         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 table'<-longhand (tableOptions a) (tableOptions b) c d+        = Just b { tableOptions = table' }     longhand a b c d         | (d', _:_)<-testLengthProp d, Just _<-longhand (inner a) (inner b) c d' =             Just b {@@ -298,28 +321,6 @@             }}       where p x = Numbered x Nothing -    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "initial"] =-        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }-    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "start"] =-        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }-    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "end"] =-        Just self { paragraphOptions = o { paragraphAlignment = AlignEnd } }-    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "left"] =-        Just self { paragraphOptions = o { paragraphAlignment = AlignLeft } }-    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "right"] =-        Just self { paragraphOptions = o { paragraphAlignment = AlignRight } }-    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "center"] =-        Just self { paragraphOptions = o { paragraphAlignment = AlignCentreH } }-    -- text-align: justify is unimplemented.-    longhand p self@CSSBox { paragraphOptions = o } "text-align"-            [Ident "match-parent"] = case paragraphAlignment$paragraphOptions p of-        AlignStart | DirLTR <- direction p -> ret AlignLeft-        AlignStart | DirRTL <- direction p -> ret AlignRight-        AlignEnd | DirLTR <- direction p -> ret AlignRight-        AlignEnd | DirRTL <- direction p -> ret AlignLeft-        x -> ret x-      where ret x = Just self { paragraphOptions = o { paragraphAlignment = x } }-     longhand _ _ _ _ = Nothing      shorthand self "font" toks = case parseOperands toks of@@ -369,6 +370,7 @@     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 | ret@(_:_) <- shorthand (tableOptions self) k v = ret     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' =

@@ -27,7 +27,7 @@     trackNats :: [Double],     -- | How much space to add between cells.     gap :: x-}+} deriving (Show, Read, Eq, Ord) -- | Which cells a child should be aligned to. type GridItem = Size GridItem' GridItem' -- | How a grid child should be aligned per-axis.

@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}+module Graphics.Layout.Grid.Table where++import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))+import Stylist (PropertyParser(..))+import Graphics.Layout.CSS.Length (Unitted, parseLength, Font', finalizeLength)+import Graphics.Layout.Box (Length(..), PaddedBox(..), zero, mapX, mapY)+import Graphics.Layout.Grid (Alignment(..))+import Data.Text.Glyphize (Direction(..))+import Data.Text.ParagraphLayout.Rich (+        ParagraphOptions(..), ParagraphAlignment(..))++import Text.Read (readMaybe)+import Data.Text (unpack)++type Overflowed = [Int]++emptyRow :: Overflowed+emptyRow = []++commitRow :: Overflowed -> Overflowed+commitRow = map $ Prelude.max 0 . pred++allocCol :: Int -> Overflowed -> Int+allocCol ix cols = ix + length (span (> 0) $ drop ix cols)++insertCell :: Int -> Int -> Int -> Overflowed -> Overflowed+insertCell ix colspan rowspan cols =+    before ++ replicate colspan rowspan ++ drop colspan after+  where (before, after) = splitAt ix cols++data TableOptions = TableOptions {+    -- | HTML rowspan attribute+    rowspan :: Int,+    -- | HTML colspan attribute+    colspan :: Int,+    -- | Parsed CSS caption-side.+    captionBelow :: Bool,+    -- | Parsed CSS border-collapse+    borderCollapse :: Bool,+    -- | Semi-parsed border-spacing, horizontal axis+    borderHSpacing :: Unitted,+    -- | Semi-parsed border-spacing, vertical axis+    borderVSpacing :: Unitted,+    -- TODO: Implement `table-layout: fixed`, that needs its own layout formula...+    -- | Parsed CSS vertical-align+    verticalAlign :: Unitted+}++instance PropertyParser TableOptions where+    temp = TableOptions {+        rowspan = 1, colspan = 1,+        captionBelow = False, borderCollapse = False,+        borderHSpacing = (0,"px"), borderVSpacing = (0,"px"),+        verticalAlign = (0,"baseline")+    }+    inherit = id++    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 = fromEnum 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 = fromEnum 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}++    longhand _ self "border-collapse" [Ident "collapse"] =+        Just self { borderCollapse = True }+    longhand _ self "border-collapse" [Ident "separate"] =+        Just self { borderCollapse = False }+    longhand _ self "border-collapse" [Ident "initial"] =+        Just self { borderCollapse = False }++    longhand _ self "border-spacing" v@[Dimension _ _ _] | Just x <- parseLength v =+        Just self { borderHSpacing = x, borderVSpacing = x }+    longhand _ self "border-spacing" [x@(Dimension _ _ _), y@(Dimension _ _ _)]+            | Just x' <- parseLength [x], Just y' <- parseLength [y] =+        Just self { borderHSpacing = x', borderVSpacing = y' }+    longhand _ self "border-spacing" [Ident "initial"] =+        Just self { borderHSpacing = (0,"px"), borderVSpacing = (0,"px") }++    longhand _ self "vertical-align" [Ident x]+        | x `elem` ["baseline", "sub", "super", "text-top", "text-bottom",+            "middle", "top", "bottom"] = Just self { verticalAlign = (0,x) }+        | x == "initial" = Just self { verticalAlign = (0,"baseline") }+        | otherwise = Nothing+    longhand _ self "vertical-align" v | Just x <- parseLength v =+        Just self { verticalAlign = x }++    longhand _ _ _ _ = Nothing++finalizeGap :: TableOptions -> Font' -> (Length, Length)+finalizeGap TableOptions { borderCollapse = True } _ = (Pixels 0, Pixels 0)+finalizeGap TableOptions { borderHSpacing = x, borderVSpacing = y } font =+    (finalizeLength x font, finalizeLength y font)++type UPaddedBox = PaddedBox Unitted Unitted+collapseBorders :: TableOptions -> UPaddedBox -> UPaddedBox+collapseBorders TableOptions { borderCollapse = False } ret = ret+collapseBorders _ box = box {+    margin = zero,+    border = mapX half $ mapY half $ border box+  }+collapseTBorders :: TableOptions -> UPaddedBox -> UPaddedBox+collapseTBorders TableOptions { borderCollapse = False } ret = ret+collapseTBorders _ box = box {+    padding = zero,+    border = mapX half $ mapY half $ border box+  }+half (x,u) = (x/2,u)++finalizeVAlign :: TableOptions -> Alignment+finalizeVAlign TableOptions { verticalAlign = (_,"top") } = Start+finalizeVAlign TableOptions { verticalAlign = (_,"middle") } = Mid+finalizeVAlign TableOptions { verticalAlign = (_,"bottom") } = End+finalizeVAlign _ = Start -- FIXME: Support baseline alignment!+finalizeHAlign :: ParagraphOptions -> Direction -> Alignment+finalizeHAlign (paragraphAlignment -> AlignStart) _ = Start+finalizeHAlign (paragraphAlignment -> AlignEnd) _ = End+finalizeHAlign (paragraphAlignment -> AlignLeft) DirLTR = Start+finalizeHAlign (paragraphAlignment -> AlignLeft) _ = End+finalizeHAlign (paragraphAlignment -> AlignRight) DirLTR = End+finalizeHAlign (paragraphAlignment -> AlignRight) _ = Start+finalizeHAlign (paragraphAlignment -> AlignCentreH) _ = Mid

@@ -3,7 +3,8 @@ -- wraps Balkón for the actual logic. module Graphics.Layout.Inline(paragraphMap, layoutMap, treeMap,     inlineMin, inlineSize, inlineChildren, layoutSize, layoutChildren,-    treeBox, positionTree, treeInner, FragmentTree(..)) where+    treeBox, positionTree, treeInner, treeInner', glyphs, codepoints,+    FragmentTree(..)) where  import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),                                 Fragment(..), ParagraphLayout(..), AncestorBox(..),@@ -12,7 +13,9 @@                                 activateBoxSpacing, paragraphSafeWidth) import Data.Text.ParagraphLayout.Rect (Rect(..),                                 width, height, x_max, x_min, y_min, y_max)+import qualified Data.Text.Glyphize as HB import Data.Int (Int32)+import Data.Word (Word32) import Debug.Trace (trace) -- To warn about unexpected branches!  import Graphics.Layout.Box hiding (min, max, width, height)@@ -76,6 +79,7 @@  data FragmentTree x = Branch (AncestorBox x) [FragmentTree x]     | Leaf (Fragment x)+    deriving (Show, Eq)  -- | Apply an operation to the 2nd field of the paragraph's userdata, -- for it's entire subtree.@@ -191,6 +195,15 @@ treeInner :: FragmentTree (a, b, c) -> c treeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret treeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret+treeInner' :: FragmentTree a -> a+treeInner' (Branch self _) = boxUserData self+treeInner' (Leaf self) = fragmentUserData self++glyphs :: FragmentTree x -> [(HB.GlyphInfo, HB.GlyphPos)]+glyphs (Branch _ _) = []+glyphs (Leaf self) = fragmentGlyphs self+codepoints :: FragmentTree x -> [Word32]+codepoints self = map HB.codepoint $ map fst $ glyphs self  ------ --- Taken from Balkón

@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings, ViewPatterns #-} -- | Infrastructure for parsing & desugaring text related CSS properties. module Graphics.Layout.Inline.CSS(-    CSSInline(..), Default(..), UnicodeBidi(..), applyFontInline, applyBidi) where+    CSSInline(..), Default(..), UnicodeBidi(..), applyFontInline, applyBidi,+    resolveVAlign, resolveBoxOpts, plaintext) where  import Data.CSS.Syntax.Tokens (Token(..)) import Stylist (PropertyParser(..))@@ -11,7 +12,11 @@ import Data.Text.Glyphize (Direction(..))  import Graphics.Layout.CSS.Font (Font'(..), hbUnit)+import Graphics.Layout.CSS.Length (finalizeLength, Unitted)+import Graphics.Layout.Box (Length(..))+import Graphics.Layout.Grid.Table (TableOptions(..)) -- for VAlign import Data.Char (isSpace)+import Data.Int (Int32) import Debug.Trace (trace) -- To report unexpected cases.  -- | Document text with Balkón styling options, CSS stylable.@@ -20,6 +25,10 @@ data UnicodeBidi = BdNormal | BdEmbed | BdOverride | BdIsolate         | BdIsolateOverride | BdPlainText deriving (Eq, Ord, Enum, Read, Show) +-- | Construct plain text+plaintext :: Txt.Text -> CSSInline+plaintext txt = CSSInline txt (defaultTextOptions DirLTR) BdNormal+ instance PropertyParser CSSInline where     temp = CSSInline "" (defaultTextOptions DirLTR) BdNormal     inherit (CSSInline _ opts _) = CSSInline "" opts BdNormal@@ -65,7 +74,7 @@ applyFontInline :: TextOptions -> Font' -> TextOptions applyFontInline opts font = opts {     textFont = hbFont font,-    textLineHeight = Absolute $ toEnum $ fromEnum $ lineheight font * hbUnit+    textLineHeight = Absolute $ toHB $ lineheight font   } -- | Apply Bidi chars around the inline text. FIXME: Handle the tree! applyBidi :: Default d => CSSInline -> [InnerNode Text d] -> [InnerNode Text d]@@ -110,3 +119,22 @@  class Default a where     def :: a++resolveVAlign :: Font' -> Unitted -> VerticalAlignment+resolveVAlign _ (_,"top") = AlignLineTop+resolveVAlign _ (_,"super") = AlignLineTop -- FIXME: Is there a better translation?+resolveVAlign _ (_,"text-top") = AlignLineTop -- FIXME: Better translation?+resolveVAlign _ (_,"bottom") = AlignLineBottom+resolveVAlign _ (_,"sub") = AlignLineBottom -- FIXME: Better translation?+resolveVAlign _ (_,"text-bottom") = AlignLineBottom+resolveVAlign _ (_,"baseline") = AlignBaseline 0+resolveVAlign f (_,"middle") = AlignBaseline $ toHB $ fontHeight f 'x' / 2+resolveVAlign f x | Pixels y <- finalizeLength x f = AlignBaseline $ toHB y+    | Percent y <- finalizeLength x f = AlignBaseline $ toHB $ y * lineheight f+    | otherwise = trace ("Invalid length! " ++ show x) $ AlignBaseline 0+resolveBoxOpts f grid = defaultBoxOptions {+    boxVerticalAlignment = resolveVAlign f $ verticalAlign grid+  }++toHB :: Double -> Int32+toHB = toEnum . fromEnum . (*) hbUnit

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                cattrap-version:             0.3.0.0+version:             0.3.1.0 synopsis:            Lays out boxes according to the CSS Box Model. description:         Computes where to place e.g. images, paragraphs, containers, tables, etc onscreen given desired amounts of whitespace. homepage:            https://argonaut-constellation.org/@@ -26,7 +26,8 @@                         Graphics.Layout.Grid, Graphics.Layout.Grid.CSS,                         Graphics.Layout.Box, Graphics.Layout.Arithmetic,                         Graphics.Layout.CSS.Length, Graphics.Layout.CSS.Font,-                        Graphics.Layout.Inline, Graphics.Layout.Inline.CSS+                        Graphics.Layout.Inline, Graphics.Layout.Inline.CSS,+                        Graphics.Layout.Grid.Table   other-modules:        Graphics.Layout.CSS.Parse   -- other-extensions:   build-depends:       base >=4.12 && <5, containers, parallel >= 3,@@ -34,7 +35,7 @@                         stylist-traits >= 0.1.3.0 && < 1,                         fontconfig-pure >= 0.2 && < 0.5,                         harfbuzz-pure >= 1.0.3.2 && < 1.1, bytestring,-                        balkon >= 1.2 && <2, unordered-containers+                        balkon >= 1.2 && <2, unordered-containers, data-array-byte   -- hs-source-dirs:   default-language:    Haskell2010   ghc-options:         -Wincomplete-patterns@@ -70,4 +71,5 @@   type:                exitcode-stdio-1.0   main-is:             Test.hs   build-depends:       base, cattrap, hspec >= 2 && < 3, QuickCheck >= 2 && < 3,-                        css-syntax, stylist-traits, unordered-containers+                        css-syntax, stylist-traits, unordered-containers,+                        balkon, harfbuzz-pure

@@ -6,6 +6,7 @@ import Graphics.Layout.Arithmetic import Data.CSS.Syntax.Tokens (tokenize, Token(..)) import Stylist (PropertyParser(..))+import Stylist.Tree (StyleTree(..)) import Data.Maybe (fromJust)  import Graphics.Layout.Box as B@@ -13,6 +14,17 @@ import Graphics.Layout.Flow import Graphics.Layout +import Graphics.Layout.CSS+import Graphics.Layout.Grid.Table+import Graphics.Layout.Inline.CSS+import Graphics.Layout.CSS.Font (placeholderFont)++import Data.Text.ParagraphLayout.Rich (constructParagraph,+        defaultParagraphOptions, defaultTextOptions,+        InnerNode(..), Box(..), RootNode(..))+import Data.Text.ParagraphLayout (PageOptions(..))+import Data.Text.Glyphize (Direction(..))+ import Graphics.Layout.Grid.CSS (parseASCIIGrid) import qualified Data.HashMap.Lazy as HM @@ -303,6 +315,102 @@             test [["head", "nav", "head"]]             test [["head"], ["nav"], ["head"]]             test [["head", "head"], ["head", "nav"]]+    describe "<table>" $ do+        it "parses to grids" $ do+            -- <table>+            --  <caption>Test table</caption>+            --  <thead><tr><th>A</th><th rowspan="2">B</th><th>C</th></tr></thead>+            --  <tbody><tr><td colspan="2">D</td><td colspan="2">E</td></tr></tbody>+            --  <tfoot><tr><td>F</td><td>G</td><td>H</td></tr></tfoot>+            -- </table>+            let text' txt = StyleTree temp { inlineStyles = plaintext txt } []+            let table :: StyleTree (CSSBox ())+                table = StyleTree temp { display = Table } [+                  StyleTree temp { display = TableHeaderGroup } [+                      StyleTree temp { display = TableRow } [+                          StyleTree temp { display = TableCell } [text' "A"],+                          StyleTree temp {+                              display = TableCell,+                              tableOptions = temp { rowspan = 2 }+                          } [text' "B"],+                          StyleTree temp { display = TableCell } [text' "C"]+                      ]+                  ],+                  StyleTree temp { display = TableRowGroup } [+                      StyleTree temp { display = TableRow } [+                          StyleTree temp {+                              display = TableCell,+                              tableOptions = temp { colspan = 2 }+                          } [text' "D"],+                          StyleTree temp {+                              display = TableCell,+                              tableOptions = temp { colspan = 2 }+                          } [text' "E"]+                      ]+                  ],+                  StyleTree temp { display = TableFooterGroup } [+                      StyleTree temp { display = TableRow } [+                          StyleTree temp { display = TableCell } [text' "F"],+                          StyleTree temp { display = TableCell } [text' "G"],+                          StyleTree temp { display = TableCell } [text' "H"]+                      ]+                  ],+                  StyleTree temp { display = TableCaption } [text' "Test table"]+                 ]+            let defaultPageOptions = PageOptions 0 0 2 2+            let gridItem x y = GridItem {+                cellStart = x, cellEnd = y,+                alignment = Start,+                minSize = 0, natSize = 0+              }+            let track cells' = Track {+                cells = cells',+                trackMins = [], trackNats = [], gap = Pixels 0+            }+            let inline txt = LayoutInline () (constructParagraph "" (+                        RootBox $ Box [+                            TextSequence ((placeholderFont, 12), zero, ()) txt+                        ] $ defaultTextOptions DirLTR+                    ) "" defaultParagraphOptions) defaultPageOptions+            finalizeCSS placeholderFont placeholderFont table `shouldBe`+                    LayoutFlow () lengthBox [+                        LayoutFlow () lengthBox [inline "Test table"],+                        LayoutGrid () Size {+                           inline = track [Left Auto, Left Auto, Left Auto, Left Auto, Left Auto, Left Auto],+                           block = track [Left Auto, Left Auto, Left Auto]+                        } [+                            gridItem 0 6 `Size` gridItem 0 1,+                            gridItem 0 6 `Size` gridItem 1 2,+                            gridItem 0 6 `Size` gridItem 2 3,+                            gridItem 0 6 `Size` gridItem 3 4,+                            gridItem 0 6 `Size` gridItem 4 5,+                            gridItem 0 6 `Size` gridItem 5 6,+                            gridItem 1 2 `Size` gridItem 0 1,+                            gridItem 3 4 `Size` gridItem 0 2,+                            gridItem 5 6 `Size` gridItem 0 1,+                            gridItem 1 3 `Size` gridItem 1 2,+                            gridItem 4 6 `Size` gridItem 1 2,+                            gridItem 1 2 `Size` gridItem 2 3,+                            gridItem 3 4 `Size` gridItem 2 3,+                            gridItem 5 6 `Size` gridItem 2 3+                        ] [+                            LayoutFlow () lengthBox [],+                            LayoutFlow () lengthBox [],+                            LayoutFlow () lengthBox [],+                            LayoutFlow () lengthBox [],+                            LayoutFlow () lengthBox [],+                            LayoutFlow () lengthBox [],+                            LayoutFlow () lengthBox [inline "A"],+                            LayoutFlow () lengthBox [inline "B"],+                            LayoutFlow () lengthBox [inline "C"],+                            LayoutFlow () lengthBox [inline "D"],+                            LayoutFlow () lengthBox [inline "E"],+                            LayoutFlow () lengthBox [inline "F"],+                            LayoutFlow () lengthBox [inline "G"],+                            LayoutFlow () lengthBox [inline "H"]+                        ]+                    ]+  runMath = flip evalCalc [] . mapCalc fst . flip parseCalc [] . filter (/= Whitespace) . tokenize