diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -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 diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -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. diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -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 ? - 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) + } diff --git a/Graphics/Layout/CSS/Length.hs b/Graphics/Layout/CSS/Length.hs --- a/Graphics/Layout/CSS/Length.hs +++ b/Graphics/Layout/CSS/Length.hs @@ -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 diff --git a/Graphics/Layout/CSS/Parse.hs b/Graphics/Layout/CSS/Parse.hs --- a/Graphics/Layout/CSS/Parse.hs +++ b/Graphics/Layout/CSS/Parse.hs @@ -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' = diff --git a/Graphics/Layout/Grid.hs b/Graphics/Layout/Grid.hs --- a/Graphics/Layout/Grid.hs +++ b/Graphics/Layout/Grid.hs @@ -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. diff --git a/Graphics/Layout/Grid/Table.hs b/Graphics/Layout/Grid/Table.hs new file mode 100644 --- /dev/null +++ b/Graphics/Layout/Grid/Table.hs @@ -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 diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -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 diff --git a/Graphics/Layout/Inline/CSS.hs b/Graphics/Layout/Inline/CSS.hs --- a/Graphics/Layout/Inline/CSS.hs +++ b/Graphics/Layout/Inline/CSS.hs @@ -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 diff --git a/cattrap.cabal b/cattrap.cabal --- a/cattrap.cabal +++ b/cattrap.cabal @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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 "
" $ do + it "parses to grids" $ do + --
+ -- + -- + -- + -- + --
Test table
ABC
DE
FGH
+ 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