From 878e6868a7d2cbc0d08ebd81185775e1bbac1ca6 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 31 Oct 2023 16:10:34 +1300 Subject: [PATCH] Parse & apply CSS -styling properties. --- Graphics/Layout/Box.hs | 2 + Graphics/Layout/CSS.hs | 61 ++++++++++++------ Graphics/Layout/CSS/Length.hs | 7 +- Graphics/Layout/CSS/Parse.hs | 78 +++++++++-------------- Graphics/Layout/Grid/Table.hs | 116 +++++++++++++++++++++++++++++++++- Graphics/Layout/Inline/CSS.hs | 28 +++++++- 6 files changed, 219 insertions(+), 73 deletions(-) diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs index cea83b0..f8e8483 100644 --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -164,6 +164,8 @@ instance (Zero m, Zero n) => Zero (PaddedBox m n) where 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 index decbe2f..c85b1b8 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -46,17 +46,24 @@ finalizeCSS root parent self@StyleTree { 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 @@ -103,7 +110,7 @@ finalizeChilds root parent style' childs@(child:_) $ 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 _ _}}) @@ -112,15 +119,15 @@ finalizeChilds root parent style' childs@(child:_) 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 root parent style' childs - | (_:_) <- table = finalizeTable root parent temp table: +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' @@ -141,19 +148,20 @@ finalizeChilds root parent style' childs 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 = LayoutGrid val grid cells' childs' +-- | 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 = Pixels 0, -- Allow styling this! + gap = hGap, trackMins = [], trackNats = [] } `Size` Track { cells = replicate height $ Left Auto, - gap = Pixels 0, -- Allow styling this! + 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 @@ -183,24 +191,30 @@ finalizeTable root parent val childs = LayoutGrid val grid cells' childs' (row, rowwidth, x') = lowerRow cells 0 h x (rows, width', height') = lowerCells rest (succ h) $ commitRow x' - lowerRow (StyleTree self'@CSSBox {display=TableCell} childs:rest) ix row 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' - -- TODO: Add alignment support! cell = (GridItem start end Start 0 0 - `Size` GridItem row (row + rowspan self') Start 0 0, - finalizeCSS root parent $ StyleTree self' { display = Block } childs) + `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) + 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 = @@ -239,7 +253,9 @@ finalizeTable root parent val childs = LayoutGrid val grid cells' childs' 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 } []) + finalizeCSS root parent $ StyleTree self { + display = Block, cssBox = collapseBorders opts $ cssBox self + } []) isRowGroup (StyleTree CSSBox { display = TableRow } _) = True isRowGroup (StyleTree CSSBox { display = TableHeaderGroup } _) = True @@ -249,3 +265,8 @@ finalizeTable root parent val childs = LayoutGrid val grid cells' childs' 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 index 8b681ec..65e4c96 100644 --- 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 @@ import Graphics.Layout.Box -- 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,"vh") f = Pixels $ x*vh f 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 diff --git a/Graphics/Layout/CSS/Parse.hs b/Graphics/Layout/CSS/Parse.hs index 5eb079e..0456efc 100644 --- a/Graphics/Layout/CSS/Parse.hs +++ b/Graphics/Layout/CSS/Parse.hs @@ -14,6 +14,7 @@ import Graphics.Text.Font.Choose (Pattern, unset) 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) @@ -47,16 +48,13 @@ data CSSBox a = CSSBox { 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, - -- | HTML rowspan attribute - rowspan :: Int, - -- | HTML colspan attribute - colspan :: Int + -- | (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 @@ -97,12 +95,11 @@ instance PropertyParser a => PropertyParser (CSSBox a) where gridStyles = temp, cellStyles = temp, inlineStyles = temp, - captionBelow = False, pageOptions = PageOptions 0 0 2 2, paragraphOptions = defaultParagraphOptions { paragraphAlignment = AlignStart }, - rowspan = 1, colspan = 1 + tableOptions = temp } inherit parent = CSSBox { boxSizing = boxSizing parent, @@ -116,10 +113,9 @@ instance PropertyParser a => PropertyParser (CSSBox a) where gridStyles = inherit $ gridStyles parent, cellStyles = inherit $ cellStyles parent, inlineStyles = inherit $ inlineStyles parent, - captionBelow = captionBelow parent, pageOptions = pageOptions parent, paragraphOptions = paragraphOptions parent, - rowspan = 1, colspan = 1 + tableOptions = inherit $ tableOptions parent } priority self = concat [x font, x font', x gridStyles, x cellStyles, x inner] where x getter = priority $ getter self @@ -260,26 +256,33 @@ instance PropertyParser a => PropertyParser (CSSBox a) where 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 = 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 "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! @@ -295,6 +298,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where 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 { @@ -316,28 +321,6 @@ instance PropertyParser a => PropertyParser (CSSBox a) where }} 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 @@ -387,6 +370,7 @@ instance PropertyParser a => PropertyParser (CSSBox a) where 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/Table.hs b/Graphics/Layout/Grid/Table.hs index 4618e6f..bb0c136 100644 --- a/Graphics/Layout/Grid/Table.hs +++ b/Graphics/Layout/Grid/Table.hs @@ -1,12 +1,25 @@ +{-# 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 $ max 0 . pred +commitRow = map $ Prelude.max 0 . pred allocCol :: Int -> Overflowed -> Int allocCol ix cols = ix + length (span (> 0) $ drop ix cols) @@ -15,3 +28,104 @@ 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/CSS.hs b/Graphics/Layout/Inline/CSS.hs index 56a5dc6..c67ad09 100644 --- 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) where import Data.CSS.Syntax.Tokens (Token(..)) import Stylist (PropertyParser(..)) @@ -11,7 +12,11 @@ import Data.Text.ParagraphLayout.Rich 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. @@ -65,7 +70,7 @@ instance PropertyParser CSSInline where 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 +115,22 @@ leaf ch = TextSequence def $ Txt.singleton ch 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.30.2