From c5cdc91e33c1ef20ed082d6a7115eeccf213fc83 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 2 Jul 2023 14:50:54 +1200 Subject: [PATCH] Parse CSS borders! --- Mondrian.cabal | 3 +- lib/Graphics/Rendering/Rect/CSS.hs | 17 ++- lib/Graphics/Rendering/Rect/CSS/Border.hs | 169 ++++++++++++++++++++++ 3 files changed, 184 insertions(+), 5 deletions(-) create mode 100644 lib/Graphics/Rendering/Rect/CSS/Border.hs diff --git a/Mondrian.cabal b/Mondrian.cabal index dd0c8fc..5aa7c01 100644 --- a/Mondrian.cabal +++ b/Mondrian.cabal @@ -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, diff --git a/lib/Graphics/Rendering/Rect/CSS.hs b/lib/Graphics/Rendering/Rect/CSS.hs index 80b5635..279cf62 100644 --- a/lib/Graphics/Rendering/Rect/CSS.hs +++ b/lib/Graphics/Rendering/Rect/CSS.hs @@ -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 diff --git a/lib/Graphics/Rendering/Rect/CSS/Border.hs b/lib/Graphics/Rendering/Rect/CSS/Border.hs new file mode 100644 index 0000000..d2a28c3 --- /dev/null +++ b/lib/Graphics/Rendering/Rect/CSS/Border.hs @@ -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 -- 2.30.2