@@ 0,0 1,404 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Graphics.Layout.CSS.Parse (
+ CSSBox(..), direction, txtOpts, BoxSizing(..), Display(..)) where
+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
+import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands,
+ parseUnorderedShorthand', parseUnorderedShorthand)
+import Data.Text.ParagraphLayout (PageOptions(..))
+import Data.Text.ParagraphLayout.Rich (textDirection)
+import Data.Text.Glyphize (Direction(..))
+
+import Graphics.Layout.Box as B
+import Graphics.Text.Font.Choose (Pattern, unset)
+import Graphics.Layout.CSS.Length (Unitted, parseLength', parseLength, auto)
+import Graphics.Layout.CSS.Font (CSSFont)
+import Graphics.Layout.Grid.CSS (CSSGrid(..), CSSCell(..), Placement(..))
+import Graphics.Layout.Inline.CSS (CSSInline(..))
+
+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.
+ display :: Display,
+ -- | (Unused) Parsed CSS box-sizing
+ boxSizing :: BoxSizing,
+ -- | sizing, margins, border-width, & padding CSS properties.
+ -- Stores units in case they're needed for font-related units.
+ cssBox :: PaddedBox Unitted Unitted, -- calc()?
+ -- | Query parameters describing desired font.
+ font :: Pattern,
+ -- | Additional font-related CSS properties.
+ font' :: CSSFont,
+ -- | Caller-specified data, to parse additional CSS properties.
+ inner :: a,
+ -- | Grid-related CSS properties.
+ gridStyles :: CSSGrid,
+ -- | Grid item related CSS properties.
+ cellStyles :: CSSCell,
+ -- | inline-related CSS properties.
+ inlineStyles :: CSSInline,
+ -- | Parsed CSS caption-side.
+ captionBelow :: Bool,
+ -- | Parsed widows & orphans controlling pagination.
+ pageOptions :: PageOptions
+}
+-- | Accessor for inlineStyle's `textDirection` attribute.
+direction CSSBox { inlineStyles = CSSInline _ opts } = textDirection opts
+-- | Accessor for inlineStyle's options.
+txtOpts CSSBox { inlineStyles = CSSInline _ opts } = opts
+-- | Possible values for CSS box-sizing.
+data BoxSizing = BorderBox | ContentBox
+-- | Empty border, to use as default value.
+noborder = Border (0,"px") (0,"px") (0,"px") (0,"px")
+
+-- | Possibly values for CSS display property.
+data Display = Block | Grid | Inline | Table | None |
+ TableRow | TableHeaderGroup | TableRowGroup | TableFooterGroup | TableCell |
+ TableColumn | TableColumnGroup | TableCaption deriving Eq
+-- | Can the display value contain table-rows?
+rowContainer CSSBox { display = d } =
+ d `elem` [Table, TableHeaderGroup, TableRowGroup, TableFooterGroup]
+
+instance PropertyParser a => PropertyParser (CSSBox a) where
+ temp = CSSBox {
+ boxSizing = ContentBox,
+ display = Inline,
+ cssBox = PaddedBox {
+ B.min = Size auto auto,
+ size = Size auto auto,
+ nat = Size 0 0,
+ B.max = Size auto auto,
+ padding = noborder,
+ border = noborder,
+ margin = noborder
+ },
+ font = temp,
+ font' = temp,
+ inner = temp,
+ gridStyles = temp,
+ cellStyles = temp,
+ inlineStyles = temp,
+ captionBelow = False,
+ pageOptions = PageOptions 0 0 2 2
+ }
+ inherit parent = CSSBox {
+ boxSizing = boxSizing parent,
+ display = Inline,
+ cssBox = cssBox (temp :: CSSBox TrivialPropertyParser),
+ font = inherit $ font parent,
+ font' = inherit $ font' parent,
+ inner = inherit $ inner parent,
+ gridStyles = inherit $ gridStyles parent,
+ cellStyles = inherit $ cellStyles parent,
+ inlineStyles = inherit $ inlineStyles parent,
+ 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"] =
+ Just self { font = unset "family" $ font self}
+
+ longhand _ self "box-sizing" [Ident "content-box"] = Just self {boxSizing = ContentBox}
+ longhand _ self "box-sizing" [Ident "border-box"] = Just self {boxSizing = BorderBox}
+ longhand _ self "box-sizing" [Ident "initial"] = Just self {boxSizing = ContentBox}
+
+ longhand _ self@CSSBox {cssBox = box} "padding-top" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { padding = (padding box) { top = x } } }
+ longhand _ self@CSSBox {cssBox = box} "padding-bottom" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { padding = (padding box) { bottom = x } } }
+ longhand _ self@CSSBox {cssBox = box} "padding-left" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { padding = (padding box) { left = x } } }
+ longhand _ self@CSSBox {cssBox = box} "padding-right" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { padding = (padding box) { right = x } } }
+ longhand _ self@CSSBox {cssBox = box} "padding-inline-start" toks
+ | Just x <- parseLength toks, DirLTR <- direction self =
+ Just self { cssBox = box { padding = (padding box) { left = x } } }
+ | Just x <- parseLength toks, DirRTL <- direction self =
+ Just self { cssBox = box { padding = (padding box) { right = x } } }
+ longhand _ self@CSSBox {cssBox = box} "padding-inline-end" toks
+ | Just x <- parseLength toks, DirLTR <- direction self =
+ Just self { cssBox = box { padding = (padding box) { right = x } } }
+ | Just x <- parseLength toks, DirRTL <- direction self =
+ Just self { cssBox = box { padding = (padding box) { left = x } } }
+
+ longhand _ self@CSSBox {cssBox = box} "border-top-width" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { border = (border box) { top = x } } }
+ longhand _ self@CSSBox {cssBox = box} "border-bottom-width" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { border = (border box) { bottom = x } } }
+ longhand _ self@CSSBox {cssBox = box} "border-left-width" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { border = (border box) { left = x } } }
+ longhand _ self@CSSBox {cssBox = box} "border-right-width" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { border = (border box) { right = x } } }
+ longhand p self "border-inline-start-color" toks
+ | DirLTR <- direction self = longhand p self "border-left-color" toks
+ | DirRTL <- direction self = longhand p self "border-right-color" toks
+ longhand p self "border-inline-start-width" toks
+ | DirLTR <- direction self = longhand p self "border-left-width" toks
+ | DirRTL <- direction self = longhand p self "border-right-width" toks
+ longhand p self "border-inline-start-style" toks
+ | DirLTR <- direction self = longhand p self "border-left-style" toks
+ | DirRTL <- direction self = longhand p self "border-right-style" toks
+ longhand p self "border-inline-end-color" toks
+ | DirLTR <- direction self = longhand p self "border-right-color" toks
+ | DirRTL <- direction self = longhand p self "border-left-color" toks
+ longhand p self "border-inline-end-width" toks
+ | DirLTR <- direction self = longhand p self "border-right-width" toks
+ | DirRTL <- direction self = longhand p self "border-left-width" toks
+ longhand p self "border-inline-end-style" toks
+ | DirLTR <- direction self = longhand p self "border-right-style" toks
+ | DirRTL <- direction self = longhand p self "border-left-style" toks
+ longhand p self "border-start-start-radius" t
+ | DirLTR <- direction self = longhand p self "border-top-left-radius" t
+ | DirRTL <- direction self = longhand p self "border-top-right-radius" t
+ longhand p self "border-start-end-radius" t
+ | DirLTR <- direction self = longhand p self "border-top-right-radius" t
+ | DirRTL <- direction self = longhand p self "border-top-left-radius" t
+ longhand p s "border-end-start-radius" t
+ | DirLTR <- direction s = longhand p s "border-bottom-left-radius" t
+ | DirRTL <- direction s = longhand p s "border-bottom-right-radius" t
+ longhand p s "border-end-end-radius" t
+ | DirLTR <- direction s = longhand p s "border-bottom-right-radius" t
+ | DirRTL <- direction s = longhand p s "border-bottom-left-radius" t
+
+ longhand _ self@CSSBox {cssBox = box} "margin-top" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { margin = (margin box) { top = x } } }
+ longhand _ self@CSSBox {cssBox = box} "margin-bottom" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { margin = (margin box) { bottom = x } } }
+ longhand _ self@CSSBox {cssBox = box} "margin-left" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { margin = (margin box) { left = x } } }
+ longhand _ self@CSSBox {cssBox = box} "margin-right" toks | Just x <- parseLength toks =
+ Just self { cssBox = box { margin = (margin box) { right = x } } }
+ longhand _ self@CSSBox {cssBox = box} "margin-inline-start" toks
+ | Just x <- parseLength toks, DirLTR <- direction self =
+ Just self { cssBox = box { margin = (margin box) { left = x } } }
+ | Just x <- parseLength toks, DirRTL <- direction self =
+ Just self { cssBox = box { margin = (margin box) { right = x } } }
+ longhand _ self@CSSBox {cssBox = box} "margin-inline-end" toks
+ | Just x <- parseLength toks, DirLTR <- direction self =
+ Just self { cssBox = box { margin = (margin box) { right = x } } }
+ | Just x <- parseLength toks, DirRTL <- direction self =
+ Just self { cssBox = box { margin = (margin box) { left = x } } }
+
+ -- Placeholder implementations until vertical text is implemented.
+ longhand p self "padding-block-start" t = longhand p self "padding-top" t
+ longhand p self "padding-block-end" t = longhand p self "padding-bottom" t
+ longhand p self "margin-block-start" t = longhand p self "margin-top" t
+ longhand p self "margin-block-end" t = longhand p self "margin-bottom" t
+ longhand p self "border-block-start-color" toks =
+ longhand p self "border-top-color" toks
+ longhand p self "border-block-start-style" toks =
+ longhand p self "border-top-style" toks
+ longhand p self "border-block-start-width" toks =
+ longhand p self "border-top-width" toks
+ longhand p s "border-block-end-color" t = longhand p s "border-bottom-color" t
+ longhand p s "border-block-end-style" t = longhand p s "border-bottom-style" t
+ longhand p s "border-block-end-width" t = longhand p s "border-bottom-width" t
+
+ longhand _ self@CSSBox {cssBox = box} "width" toks | Just x <- parseLength' toks =
+ Just self { cssBox = box { size = (size box) { inline = x } } }
+ longhand _ self@CSSBox {cssBox = box} "height" toks | Just x <- parseLength' toks =
+ Just self { cssBox = box { size = (size box) { block = x } } }
+ longhand _ self@CSSBox {cssBox = box} "max-width" toks | Just x <- parseLength' toks =
+ Just self { cssBox = box { B.max = (B.max box) { inline = x } } }
+ longhand _ self@CSSBox {cssBox = box} "min-width" toks | Just x <- parseLength' toks =
+ Just self { cssBox = box { B.min = (B.min box) { inline = x } } }
+ longhand _ self@CSSBox {cssBox = box} "max-height" toks | Just x <- parseLength' toks =
+ Just self { cssBox = box { B.max = (B.max box) { block = x } } }
+ longhand _ self@CSSBox {cssBox = box} "min-height" toks | Just x <- parseLength' toks =
+ Just self { cssBox = box { B.min = (B.min box) { block = x } } }
+
+ 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 CSSBox { display = Table } self "display" [Ident "table-row-group"] =
+ Just self { display=TableRowGroup }
+ longhand CSSBox { display = Table } self "display" [Ident "table-header-group"] =
+ Just self { display = TableHeaderGroup }
+ longhand CSSBox { display = Table } self "display" [Ident "table-footer-group"] =
+ Just self { display = TableFooterGroup }
+ longhand parent self "display" [Ident "table-row"] | rowContainer parent =
+ Just self { display = TableRow }
+ longhand CSSBox { display = TableRow } self "display" [Ident "table-cell"] =
+ Just self { display = TableCell }
+ longhand CSSBox { display = Table } self "display" [Ident "table-column-group"] =
+ Just self { display = TableColumnGroup }
+ 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 } -}
+ 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 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!
+ longhand a b c d | Just font' <- longhand (font a) (font b) c d = Just b {
+ font = font'
+ }
+ longhand a b c d | Just font <- longhand (font' a) (font' b) c d = Just b {
+ font' = font
+ }
+ longhand a b c d | Just inline' <- longhand (inlineStyles a) (inlineStyles b) c d =
+ Just b { inlineStyles = inline' }
+ longhand a b c d | Just grid' <- longhand (gridStyles a) (gridStyles b) c d =
+ 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 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-inline" toks = parseUnorderedShorthand self [
+ "border-inline-color", "border-inline-style", "border-inline-width"] toks
+ shorthand self "border-inline-start" toks = parseUnorderedShorthand self [
+ "border-inline-start-color", "border-inline-start-style",
+ "border-inline-start-width"] toks
+ shorthand self "border-inline-end" toks = parseUnorderedShorthand self [
+ "border-inline-end-color", "border-inline-end-style",
+ "border-inline-end-width"] toks
+ shorthand self "border-block" toks = parseUnorderedShorthand self [
+ "border-block-color", "border-block-style", "border-block-width"] toks
+ shorthand self "border-block-start" toks = parseUnorderedShorthand self [
+ "border-block-start-color", "border-block-start-style",
+ "border-block-start-width"] toks
+ shorthand self "border-block-end" toks = parseUnorderedShorthand self [
+ "border-block-end-color", "border-block-end-style",
+ "border-block-end-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 "border-inline-color" toks
+ | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
+ all (validProp self "border-inline-start-color") x =
+ [("border-inline-start-color", s), ("border-inline-end-color", e)]
+ where x = parseOperands toks
+ shorthand self "border-inline-style" toks
+ | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
+ all (validProp self "border-inline-start-style") x =
+ [("border-inline-start-style", s), ("border-inline-end-style", e)]
+ where x = parseOperands toks
+ shorthand self "border-inline-width" toks
+ | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
+ all (validProp self "border-inline-start-width") x =
+ [("border-inline-start-width", s), ("border-inline-end-style", e)]
+ where x = parseOperands toks
+ shorthand self "border-block-color" toks
+ | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
+ all (validProp self "border-block-start-color") x =
+ [("border-block-start-color", s), ("border-block-end-color", e)]
+ where x = parseOperands toks
+ shorthand self "border-block-style" toks
+ | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
+ all (validProp self "border-block-start-style") x =
+ [("border-block-start-style", s), ("border-block-end-style", e)]
+ where x = parseOperands toks
+ shorthand self "border-block-width" toks
+ | length x > 0 && length x <= 2, (s:e:_) <- cycle x,
+ all (validProp self "border-block-start-width") x =
+ [("border-block-start-width", s), ("border-block-end-width", e)]
+ 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