From 3e2dcdd310874d60ca44f4e8412556f5b39cbfcb Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 23 May 2023 14:47:20 +1200 Subject: [PATCH] Implement property prioritization & shorthands. --- Graphics/Layout/CSS.hs | 101 ++++++++++++++++++++++++- Graphics/Layout/CSS/Font.hs | 1 + Graphics/Layout/CSS/Length.hs | 2 + Graphics/Layout/Grid/CSS.hs | 134 +++++++++++++++++++++++++++++++--- 4 files changed, 228 insertions(+), 10 deletions(-) diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index f1ee6ba..f8abc41 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -5,7 +5,8 @@ module Graphics.Layout.CSS(CSSBox(..), BoxSizing(..), Display(..), import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import qualified Data.Text as Txt -import Stylist (PropertyParser(..), TrivialPropertyParser) +import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands, + parseUnorderedShorthand', parseUnorderedShorthand) import Stylist.Tree (StyleTree(..)) import Data.Text.ParagraphLayout (PageOptions(..)) @@ -17,6 +18,9 @@ import Graphics.Layout.CSS.Font import Graphics.Layout.Grid.CSS import Graphics.Layout.Inline.CSS +import Data.Maybe (isJust, fromMaybe) +import qualified Data.HashMap.Lazy as HM + -- | Parsed CSS properties relevant to layout. data CSSBox a = CSSBox { -- | Which layout formula to use, a.k.a. parsed CSS display property. @@ -91,6 +95,8 @@ instance PropertyParser a => PropertyParser (CSSBox a) where captionBelow = captionBelow parent, pageOptions = pageOptions parent } + priority self = concat [x font, x font', x gridStyles, x cellStyles, x inner] + where x getter = priority $ getter self -- Wasn't sure how to implement in FontConfig-Pure longhand _ self "font-family" [Ident "initial"] = @@ -188,8 +194,101 @@ instance PropertyParser a => PropertyParser (CSSBox a) where longhand a b c d | Just inner' <- longhand (inner a) (inner b) c d = Just b { inner = inner' } + + -- Technically a grid shorthand, but we need parent data to parse it! + longhand CSSBox { gridStyles = parent } self "grid-area" [Ident x] + | Just ((colS, colE), (rowS, rowE)) <- x `HM.lookup` templateAreas parent + = Just self { cellStyles = (cellStyles self) { + columnStart = p colS, + columnEnd = p colE, + rowStart = p rowS, + rowEnd = p $ fromMaybe (length $ templateAreas parent) rowE + }} + where p x = Numbered x Nothing + longhand _ _ _ _ = Nothing + shorthand self "font" toks = case parseOperands toks of + (a:b:c:d:toks') | ret@(_:_) <- unordered [a,b,c,d] -> inner ret toks' + (a:b:c:toks') | ret@(_:_) <- unordered [a,b,c] -> inner ret toks' + (a:b:toks') | ret@(_:_) <- unordered [a,b] -> inner ret toks' + (a:toks') | ret@(_:_) <- unordered [a] -> inner ret toks' + toks' -> inner [] toks' + where + unordered operands = parseUnorderedShorthand' self [ + "font-style", "font-variant", "font-weight", "font-stretch"] operands + inner ret (size:[Delim '/']:height:family) + | Just _ <- longhand self self "font-size" size, + Just _ <- longhand self self "line-height" height, + Just _ <- longhand self self "font-family" $ concat family = + ("font-size", size):("line-height", height): + ("font-family", concat family):ret + | otherwise = [] + inner ret (size:family) + | Just _ <- longhand self self "font-size" size, + Just _ <- longhand self self "font-family" $ concat family = + ("font-size", size):("line-height", [Ident "initial"]): + ("font-family", concat family):ret + | otherwise = [] + inner _ _ = [] + shorthand self "margin" toks + | length x > 0 && length x <= 4, all (validProp self "margin-top") x, + (top:right:bottom:left:_) <- cycle x = + [("margin-top", top), ("margin-right", right), + ("margin-bottom", bottom), ("margin-left", left)] + where x = parseOperands toks + shorthand self "padding" toks + | length x > 0 && length x <= 4, all (validProp self "padding-top") x, + (top:right:bottom:left:_) <- cycle x = + [("padding-top", top), ("padding-right", right), + ("padding-bottom", bottom), ("padding-left", left)] + where x = parseOperands toks + shorthand self "border-width" toks + | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, + all (validProp self "border-top-width") x = + [("border-top-width", top), ("border-right-width", right), + ("border-bottom-width", bottom), ("border-left-width", left)] + where x = parseOperands toks + -- Define other border shorthands here to properly handle border-widths + shorthand self "border" toks = parseUnorderedShorthand self [ + "border-color", "border-style", "border-width"] toks + shorthand self "border-top" toks = parseUnorderedShorthand self [ + "border-top-color", "border-top-style", "border-top-width"] toks + shorthand self "border-right" toks = parseUnorderedShorthand self [ + "border-right-color", "border-right-style", "border-right-width"] toks + shorthand self "border-bottom" toks = parseUnorderedShorthand self [ + "border-bottom-color", "border-bottom-style", "border-bottom-width"] toks + shorthand self "border-left" toks = parseUnorderedShorthand self [ + "border-left-color", "border-left-style", "border-left-width"] toks + shorthand self "border-color" toks + | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, + all (validProp self "border-top-color") x = + [("border-top-color", top), ("border-right-color", right), + ("border-bottom-color", bottom), ("border-left-color", left)] + where x = parseOperands toks + shorthand self "border-style" toks + | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, + all (validProp self "border-top-style") x = + [("border-top-style", top), ("border-right-style", right), + ("border-bottom-style", bottom), ("border-left-style", left)] + where x = parseOperands toks + shorthand self "border-width" toks + | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x, + all (validProp self "border-top-width") x = + [("border-top-width", top), ("border-right-width", right), + ("border-bottom-width", bottom), ("border-left-width", left)] + where x = parseOperands toks + + shorthand self k v | Just _ <- longhand self self k v = [(k, v)] + shorthand self k v | ret@(_:_) <- shorthand (font self) k v = ret + shorthand self k v | ret@(_:_) <- shorthand (font' self) k v = ret + 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 = shorthand (inner self) k v + +validProp self key value = isJust $ longhand self self key value + -- | Desugar parsed CSS into more generic layout parameters. finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) -> LayoutItem Length Length x diff --git a/Graphics/Layout/CSS/Font.hs b/Graphics/Layout/CSS/Font.hs index 1806ddf..037a20c 100644 --- a/Graphics/Layout/CSS/Font.hs +++ b/Graphics/Layout/CSS/Font.hs @@ -121,6 +121,7 @@ instance PropertyParser CSSFont where opticalSize = True } inherit parent = parent + priority _ = [] longhand _ self "font-size" [Ident "xx-small"] = fracDefault self $ 3/5 longhand _ self "font-size" [Ident "x-small"] = fracDefault self $ 3/4 diff --git a/Graphics/Layout/CSS/Length.hs b/Graphics/Layout/CSS/Length.hs index ec4cda3..cf735c1 100644 --- a/Graphics/Layout/CSS/Length.hs +++ b/Graphics/Layout/CSS/Length.hs @@ -55,7 +55,9 @@ finalizeLength (x,"lh") f = Pixels $ x*lineheight f finalizeLength (x,"rem") f = Pixels $ x*rootEm f finalizeLength (x,"rlh") f = Pixels $ x*rlh f 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,"px") f = Pixels $ x*scale f diff --git a/Graphics/Layout/Grid/CSS.hs b/Graphics/Layout/Grid/CSS.hs index 3dcad9d..8a54234 100644 --- a/Graphics/Layout/Grid/CSS.hs +++ b/Graphics/Layout/Grid/CSS.hs @@ -3,7 +3,7 @@ module Graphics.Layout.Grid.CSS(CSSGrid(..), Axis(..), CSSCell(..), Placement(..), finalizeGrid, Areas, parseASCIIGrid) where -import Stylist (PropertyParser(..)) +import Stylist (PropertyParser(..), parseOperands) import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import Data.Text (Text) @@ -18,8 +18,6 @@ import Graphics.Layout.Box import Graphics.Layout.Grid import Graphics.Layout -import Debug.Trace - type Areas = HM.HashMap Text ((Int, Int), (Int, Maybe Int)) -- | Converts a grid to lookup table start & indices for row & columns. @@ -54,7 +52,7 @@ data CSSGrid = CSSGrid { -- | Parsed CSS grid-auto-rows autoRows :: Unitted, -- | Parsed CSS grid-template-areas - templateAreas :: [[Text]], + templateAreas :: Areas, -- | Parsed CSS grid-template-columns templateColumns :: [([Text], Unitted)], -- | Parsed CSS grid-template-rows @@ -89,13 +87,14 @@ instance PropertyParser CSSGrid where autoFlow = Row, autoFlowDense = False, autoRows = auto, - templateAreas = [], + templateAreas = HM.empty, templateColumns = [], templateRows = [], cssGap = Size (0,"px") (0,"px"), alignItems = Size Start Start -- FIXME: Should be stretch, unsupported. } inherit _ = temp + priority _ = [] longhand _ s "grid-auto-columns" toks | Just x <- parseFR toks = Just s {autoColumns=x} longhand _ s "grid-auto-rows" toks | Just x <- parseFR toks = Just s { autoRows = x } @@ -113,11 +112,15 @@ instance PropertyParser CSSGrid where autoFlow = Col, autoFlowDense = True } - longhand _ self "grid-template-areas" [Ident "none"] = Just self {templateAreas = []} - longhand _ self "grid-template-areas" [Ident "initial"] = Just self {templateAreas=[]} + -- FIXME Parse & validate the ASCII-art grid into rectangles. + longhand _ self "grid-template-areas" [Ident "none"] = + Just self { templateAreas = HM.empty } + longhand _ self "grid-template-areas" [Ident "initial"] = + Just self { templateAreas = HM.empty } longhand _ self "grid-template-areas" toks - | all isString toks, validate [Txt.words x | String x <- toks] = - Just self { templateAreas = [Txt.words x | String x <- toks] } + | all isString toks, let grid = [Txt.words x | String x <- toks], + validate grid, Just areas <- parseASCIIGrid grid 0 HM.empty = + Just self { templateAreas = areas } where isString (String _) = True isString _ = False @@ -193,6 +196,7 @@ instance PropertyParser CSSCell where alignSelf = Size Nothing Nothing } inherit _ = temp + priority _ = [] longhand _ self "grid-column-start" toks | Just x <- placement toks = Just self { columnStart = x} @@ -252,6 +256,118 @@ instance PropertyParser CSSCell where longhand _ _ _ _ = Nothing + shorthand _ "grid-column" toks = case break (== Delim '/') toks of + (a, Delim '/':b) | Just _ <- placement a, Just _ <- placement b -> + [("grid-column-start", a), ("grid-column-end", b)] + _ | Just _ <- placement toks -> + [("grid-column-start", toks), ("grid-column-end", toks)] + _ -> [] + shorthand self "grid-gap" toks = case parseOperands toks of + [a] | Just _ <- longhand self self "grid-row-gap" a -> + [("grid-row-gap", a), ("grid-column-gap", a)] + [a, b] | Just _ <- longhand self self "grid-row-gap" a, + Just _ <- longhand self self "grid-column-gap" b -> + [("grid-row-gap", a), ("grid-column-gap", b)] + _ -> [] + shorthand _ "grid-row" toks = case break (== Delim '/') toks of + (a, Delim '/':b) | Just _ <- placement a, Just _ <- placement b -> + [("grid-row-start", a), ("grid-row-end", b)] + _ | Just _ <- placement toks -> + [("grid-row-start", toks), ("grid-row-end", toks)] + _ -> [] + shorthand _ "grid-template" toks@[Ident "none"] = + [("grid-template-columns", toks), ("grid-template-rows", toks), + ("grid-template-areas", toks)] + shorthand self "grid-template" toks + | (rows, Delim '/':cols) <- break (== Delim '/') toks, + Just _ <- longhand self self "grid-template-rows" rows, + Just _ <- longhand self self "grid-template-columns" cols = + [("grid-template-rows", rows), ("grid-template-columns", cols), + ("grid-template-areas", [Ident "none"])] + | (rowsTemplate, Delim '/':cols) <- break (== Delim '/') toks, + Just (areas, rows) <- splitTemplate rowsTemplate, + Just _ <- longhand self self "grid-template-cols" cols, + Just _ <- longhand self self "grid-template-areas" areas = + [("grid-template-rows", concat rows), + ("grid-template-columns", cols), ("grid-template-areas", areas)] + where + splitTemplate (LeftSquareBracket:t) + | (names, RightSquareBracket:t') <- break (== RightSquareBracket) t, + all isIdent names, Just (areas, row:rows) <- splitTemplate t' = + Just (areas, + (LeftSquareBracket:names ++ RightSquareBracket:row):rows) + splitTemplate (x@(String _):toks) + | Just (areas, rows) <- splitTemplate' toks = Just (x:areas, rows) + splitTemplate _ = Nothing + splitTemplate' (x:LeftSquareBracket:t) + | (names, RightSquareBracket:t') <- break (== RightSquareBracket) t, + all isIdent names, Just _ <- parseFR' [x], + Just (areas, rows) <- splitTemplate t' = + Just (areas, + (x:LeftSquareBracket:names ++ [RightSquareBracket]):rows) + splitTemplate' (x:toks) + | Just _ <- parseFR' [x], Just (areas, rows) <- splitTemplate toks = + Just (areas, [x]:rows) + splitTemplate' (LeftSquareBracket:t) + | (names, RightSquareBracket:t') <- break (== RightSquareBracket) t, + all isIdent names, Just (areas, rows) <- splitTemplate t' = + Just (areas, + (LeftSquareBracket:names ++ [RightSquareBracket]):rows) + splitTemplate' toks + | Just (areas, rows) <- splitTemplate toks = Just (areas, []:rows) + | otherwise = Nothing + isIdent (Ident _) = True + isIdent _ = False + shorthand self "grid" toks + | ret@(_:_) <- shorthand self "grid-template" toks = + ("grid-auto-flow", [Ident "row"]):ret + shorthand self "grid" toks = case break (== Delim '/') toks of + (rows, Delim '/':Ident "auto-flow":Ident "dense":cols) | + Just _ <- longhand self self "grid-template-rows" rows, + Just _ <- longhand self self "grid-auto-columns" cols -> + [("grid-template-rows", rows), + ("grid-template-columns", [Ident "none"]), + ("grid-auto-columns", cols), ("grid-auto-rows", [Ident "none"]), + ("grid-auto-flow", [Ident "column", Ident "dense"])] + (rows, Delim '/':Ident "dense":Ident "auto-flow":cols) | + Just _ <- longhand self self "grid-template-rows" rows, + Just _ <- longhand self self "grid-auto-columns" cols -> + [("grid-template-rows", rows), + ("grid-template-columns", [Ident "none"]), + ("grid-auto-columns", cols), ("grid-auto-rows", [Ident "none"]), + ("grid-auto-flow", [Ident "column", Ident "dense"])] + (rows, Delim '/':Ident "auto-flow":cols) | + Just _ <- longhand self self "grid-template-rows" rows, + Just _ <- longhand self self "grid-auto-columns" cols -> + [("grid-template-rows", rows), + ("grid-template-columns", [Ident "none"]), + ("grid-auto-columns", cols), ("grid-auto-rows", [Ident "none"]), + ("grid-auto-flow", [Ident "column"])] + (Ident "auto-flow":Ident "dense":rows, Delim '/':cols) | + Just _ <- longhand self self "grid-auto-rows" rows, + Just _ <- longhand self self "grid-template-columns" cols -> + [("grid-auto-rows", rows), ("grid-auto-columns", [Ident "none"]), + ("grid-template-columns", cols), + ("grid-template-rows", [Ident "none"]), + ("grid-auto-flow", [Ident "row", Ident "dense"])] + (Ident "dense":Ident "auto-flow":rows, Delim '/':cols) | + Just _ <- longhand self self "grid-auto-rows" rows, + Just _ <- longhand self self "grid-template-columns" cols -> + [("grid-auto-rows", rows), ("grid-auto-columns", [Ident "none"]), + ("grid-template-columns", cols), + ("grid-template-rows", [Ident "none"]), + ("grid-auto-flow", [Ident "row", Ident "dense"])] + (Ident "auto-flow":rows, Delim '/':cols) | + Just _ <- longhand self self "grid-auto-rows" rows, + Just _ <- longhand self self "grid-template-columns" cols -> + [("grid-auto-rows", rows), ("grid-auto-columns", [Ident "none"]), + ("grid-template-columns", cols), + ("grid-template-rows", [Ident "none"]), + ("grid-auto-flow", [Ident "row"])] + _ -> [] + shorthand self k v | Just _ <- longhand self self k v = [(k, v)] + | otherwise = [] + -- | Parse a length or FR unit. parseFR [Dimension _ x "fr"] = Just (n2f x,"fr") parseFR toks = parseLength toks -- 2.30.2