3 files changed, 184 insertions(+), 5 deletions(-)

M Mondrian.cabal
M lib/Graphics/Rendering/Rect/CSS.hs
A lib/Graphics/Rendering/Rect/CSS/Border.hs

@@ 23,7 23,8 @@ library
                        Graphics.Rendering.Rect.Image,
                        Graphics.Rendering.Rect.CSS,
                        Graphics.Rendering.Rect.CSS.Colour,
-                       Graphics.Rendering.Rect.CSS.Backgrounds
+                       Graphics.Rendering.Rect.CSS.Backgrounds,
+                       Graphics.Rendering.Rect.CSS.Border
   other-modules:       Graphics.Rendering.Rect.Types
   -- other-extensions:
   build-depends:       base >=4.13 && <4.14, stylist-traits >= 0.1.3.1 && < 1,

@@ 4,30 4,39 @@ module Graphics.Rendering.Rect.CSS(RectStyle(..), colour) where
 import Stylist (PropertyParser(..))
 import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground))
 import Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..))
+import Graphics.Rendering.Rect.CSS.Border (Border(..))
 import Data.Text (Text)
 import Data.Colour(AlphaColour)
 
 data RectStyle img = RectStyle {
     colours :: ColourPallet,
-    backgrounds :: Backgrounds img
+    backgrounds :: Backgrounds img,
+    border' :: Border
 } deriving (Eq, Show, Read)
 colour :: RectStyle img -> AlphaColour Float
 colour = foreground . colours
+border :: RectStyle img -> Border
+border self = (border' self) { borderPallet = colours self }
 
 instance PropertyParser (RectStyle Text) where
-    temp = RectStyle { colours = temp, backgrounds = temp }
+    temp = RectStyle { colours = temp, backgrounds = temp, border' = temp }
     inherit RectStyle {..} = RectStyle {
-        colours = inherit colours, backgrounds = temp
+        colours = inherit colours, backgrounds = temp, border' = temp
     }
+    priority RectStyle {..} =
+        priority colours ++ priority backgrounds ++ priority border'
 
     shorthand self key value
         | ret@(_:_) <- shorthand (backgrounds self) key value = ret
+        | ret@(_:_) <- shorthand (border self) key value = ret
         | Just _ <- longhand self self key value = [(key, value)]
         | otherwise = []
     longhand parent self key value
-        | Just ret <- longhand (backgrounds parent) { pallet = colours parent }
+        | Just ret <- longhand (backgrounds parent) { pallet = colours self }
                 (backgrounds self) { pallet = colours self } key value =
             Just self { backgrounds = ret }
         | Just ret <- longhand (colours parent) (colours self) key value =
             Just self { colours = ret }
+        | Just ret <- longhand (border parent) (border self) key value =
+            Just self { border' = ret }
         | otherwise = Nothing

@@ 0,0 1,169 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Graphics.Rendering.Rect.CSS.Border(Border(..), BorderStyle(..),
+    topColour, rightColour, bottomColour, leftColour) where
+
+import Stylist (PropertyParser(..), parseUnorderedShorthand, parseOperands)
+import Data.CSS.Syntax.Tokens (Token(..))
+import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground), parseColour)
+import Data.Colour (AlphaColour)
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+
+data Border = Border {
+    borderPallet :: ColourPallet,
+    topStyle :: BorderStyle,
+    topColour' :: Maybe (AlphaColour Float),
+    rightStyle :: BorderStyle,
+    rightColour' :: Maybe (AlphaColour Float),
+    bottomStyle :: BorderStyle,
+    bottomColour' :: Maybe (AlphaColour Float),
+    leftStyle :: BorderStyle,
+    leftColour' :: Maybe (AlphaColour Float)
+} deriving (Eq, Show, Read)
+
+resolveColour :: Border -> Maybe (AlphaColour Float) -> AlphaColour Float
+resolveColour self = fromMaybe $ foreground $ borderPallet self
+topColour, rightColour, bottomColour, leftColour :: Border -> AlphaColour Float
+topColour self = resolveColour self $ topColour' self
+rightColour self = resolveColour self $ rightColour' self
+bottomColour self = resolveColour self $ bottomColour' self
+leftColour self = resolveColour self $ leftColour' self
+
+data BorderStyle = None | Solid | Dashed | Dotted | Double
+    | Groove | Ridge | Inset | Outset deriving (Eq, Show, Read, Enum)
+
+style :: Token -> Maybe BorderStyle
+style (Ident "initial") = Just None
+style (Ident "none") = Just None
+style (Ident "hidden") = Just None
+style (Ident "solid") = Just Solid
+style (Ident "dashed") = Just Dashed
+style (Ident "dotted") = Just Dotted
+style (Ident "double") = Just Double
+style (Ident "groove") = Just Groove
+style (Ident "ridge") = Just Ridge
+style (Ident "inset") = Just Inset
+style (Ident "outset") = Just Outset
+style _ = Nothing
+
+instance PropertyParser Border where
+    temp = Border {
+        borderPallet = temp,
+        topStyle = None,
+        topColour' = Nothing,
+        rightStyle = None,
+        rightColour' = Nothing,
+        bottomStyle = None,
+        bottomColour' = Nothing,
+        leftStyle = None,
+        leftColour' = Nothing
+      }
+    inherit = const temp
+    priority = const []
+
+    longhand _ s "border-top-style" [t] | Just v <- style t = Just s {topStyle=v}
+    longhand _ s "border-right-style" [t] | Just v<-style t=Just s {rightStyle=v}
+    longhand _ s "border-bottom-style" [t]|Just v<-style t=Just s {bottomStyle=v}
+    longhand _ s "border-left-style" [t] | Just v<-style t = Just s {leftStyle=v}
+    longhand _ self@Border { borderPallet = cc } "border-top-colour" ts
+        | Just ([], v) <- parseColour cc ts = Just self { topColour' = Just v }
+    longhand _ self@Border { borderPallet = cc } "border-right-colour" ts
+        | Just ([], v) <- parseColour cc ts = Just self { rightColour' = Just v }
+    longhand _ self@Border { borderPallet = cc } "border-bottom-colour" ts
+        | Just ([], v) <- parseColour cc ts = Just self { bottomColour' = Just v }
+    longhand _ self@Border { borderPallet = cc } "border-left-colour" ts
+        | Just ([], v) <- parseColour cc ts = Just self { bottomColour' = Just v }
+
+    -- Should be handled by caller, but for the sake of shorthands...
+    longhand _ self "border-top-width" [Dimension _ _ "px"] = Just self
+    longhand _ self "border-right-width" [Dimension _ _ "px"] = Just self
+    longhand _ self "border-bottom-width" [Dimension _ _ "px"] = Just self
+    longhand _ self "border-left-width" [Dimension _ _ "px"] = Just self
+    longhand _ _ _ _ = Nothing
+
+    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)]
+        | otherwise = []
+
+validProp :: PropertyParser a => a -> Text -> [Token] -> Bool
+validProp self key value = isJust $ longhand self self key value