4 files changed, 228 insertions(+), 10 deletions(-)

M Graphics/Layout/CSS.hs
M Graphics/Layout/CSS/Font.hs
M Graphics/Layout/CSS/Length.hs
M Graphics/Layout/Grid/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

@@ 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

@@ 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

@@ 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