From d27996ebcac2e0f1d2539634021452b5eb6966cf Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 9 Aug 2022 16:00:55 +1200 Subject: [PATCH] Parse @layer rules. --- src/Data/CSS/Syntax/AtLayer.hs | 70 ++++++++++++++++++++++++++++++++++ stylist.cabal | 3 +- test/Test.hs | 15 ++++++++ 3 files changed, 87 insertions(+), 1 deletion(-) create mode 100644 src/Data/CSS/Syntax/AtLayer.hs diff --git a/src/Data/CSS/Syntax/AtLayer.hs b/src/Data/CSS/Syntax/AtLayer.hs new file mode 100644 index 0000000..cd8aaed --- /dev/null +++ b/src/Data/CSS/Syntax/AtLayer.hs @@ -0,0 +1,70 @@ +module Data.CSS.Syntax.AtLayer where + +import Data.HashMap.Lazy as M (HashMap, (!?), insert, size, empty) +import Data.Text as T hiding (reverse, replicate, length) +import Data.CSS.Syntax.Tokens + +import Stylist.Parse + +parseAtLayer :: StyleSheet s => [Text] -> [Token] -> Tree -> + ([Text] -> [Int] -> s) -> (Tree, Maybe s, [Token]) +parseAtLayer namespace (Whitespace:toks) tree cb = parseAtLayer namespace toks tree cb +parseAtLayer namespace (Ident layer:toks) tree cb = inner toks [layer] tree + where + inner (Delim '.':Ident sublayer:toks') layers tree' = inner toks' (sublayer:layers) tree' + inner (Whitespace:toks') layers tree' = inner toks' layers tree' + inner (Comma:toks') layers tree' = + let (ret, tail') = parseLayerStmt namespace toks' $registerLayer (namespaced layers) tree' + in (ret, Nothing, tail') + inner (LeftCurlyBracket:toks') layers tree' = + let (ret, styles, tail') = parseLayerBlock (namespaced layers) toks' tree' cb + in (ret, Just styles, tail') + inner (Semicolon:toks') layers tree' = (registerLayer (namespaced layers) tree', Nothing, toks') + inner [] layers tree' = (registerLayer (namespaced layers) tree', Nothing, []) + inner toks' _ _ = (tree, Nothing, skipAtRule toks') + namespaced layers = namespace ++ reverse layers +parseAtLayer ns (LeftCurlyBracket:toks) tree cb = + let (ret, styles, tail') = parseLayerBlock (uniqueName ns tree) toks tree cb + in (ret, Just styles, tail') +parseAtLayer _ toks tree _ = (tree, Nothing, skipAtRule toks) + +parseLayerStmt :: [Text] -> [Token] -> Tree -> (Tree, [Token]) +parseLayerStmt namespace (Whitespace:toks) tree = parseLayerStmt namespace toks tree +parseLayerStmt namespace (Ident layer:toks) tree = inner toks [layer] tree + where + inner (Delim '.':Ident sublayer:toks') layers tree' = inner toks' (sublayer:layers) tree' + inner (Comma:toks') layers tree' = + parseLayerStmt namespace toks' $ registerLayer (namespaced layers) tree' + inner (Whitespace:toks') layers tree' = inner toks' layers tree' + inner (Semicolon:toks') layers tree' = (registerLayer (namespaced layers) tree', toks') + inner [] layers tree' = (registerLayer (namespaced layers) tree', []) + inner toks' _ _ = (tree, skipAtRule toks') + namespaced layers = namespace ++ reverse layers +parseLayerStmt _ toks tree = (tree, skipAtRule toks) + +parseLayerBlock :: StyleSheet s => [Text] -> [Token] -> Tree -> + ([Text] -> [Int] -> s) -> (Tree, s, [Token]) +parseLayerBlock layers toks tree cb = (tree', parse' styles block, toks') + where + (block, toks') = scanBlock toks + tree' = registerLayer layers tree + styles = cb layers $ layerPath layers tree' + +newtype Tree = Tree (HashMap Text (Int, Tree)) +registerLayer :: [Text] -> Tree -> Tree +registerLayer (layer:sublayers) (Tree self) + | Just (ix, subtree) <- self !? layer = Tree $ insert layer (ix, registerLayer sublayers subtree) self + | otherwise = Tree $ insert layer (succ $ size self, registerLayer sublayers $ Tree M.empty) self +registerLayer [] self = self + +layerPath :: [Text] -> Tree -> [Int] +layerPath (layer:sublayers) (Tree self) + | Just (ix, subtree) <- self !? layer = ix:layerPath sublayers subtree + | otherwise = [] -- Should have registered first... +layerPath [] _ = [] + +uniqueName :: [Text] -> Tree -> [Text] +uniqueName (namespace:namespaces) (Tree self) + | Just (_, subtree) <- self !? namespace = namespace:uniqueName namespaces subtree + | otherwise = replicate (length namespaces + 2) T.empty -- Should have registered first +uniqueName [] (Tree self) = [T.pack $ show $ size self] diff --git a/stylist.cabal b/stylist.cabal index c48216c..0f5f423 100644 --- a/stylist.cabal +++ b/stylist.cabal @@ -61,7 +61,8 @@ library -- Modules included in this library but not exported. other-modules: Data.CSS.Style.Importance, Data.CSS.Style.Common, Data.CSS.Style.Cascade, Data.CSS.Style.Selector.Index, Data.CSS.Style.Selector.Interpret, - Data.CSS.Style.Selector.Specificity, Data.CSS.Style.Selector.LowerWhere + Data.CSS.Style.Selector.Specificity, Data.CSS.Style.Selector.LowerWhere, + Data.CSS.Syntax.AtLayer -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/test/Test.hs b/test/Test.hs index 3bff696..1bb5c0d 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -3,6 +3,7 @@ module Main where import Test.Hspec import Data.HashMap.Strict +import qualified Data.HashMap.Lazy as L import Data.Maybe (fromJust) import Network.URI import Data.Scientific (toRealFloat) @@ -11,6 +12,8 @@ import Data.CSS.Syntax.Tokens import Data.CSS.Syntax.StyleSheet (parse, StyleSheet(..), TrivialStyleSheet(..), scanAtRule, scanValue) import Data.CSS.Syntax.Selector +import Data.CSS.Syntax.AtLayer + import Data.CSS.Style.Common import Data.CSS.Style.Selector.Index import Data.CSS.Style.Selector.Interpret @@ -504,6 +507,18 @@ spec = do let textStyle4 = fromJust $ longhand temp textStyle1 "counter-increment" [Ident "-rhaps-ol"] style (Txt.resolve $ StyleTree textStyle4 []) `shouldBe` TrivialPropertyParser (fromList [("content", [String "1"])]) + describe "@layer" $ do + it "Deduplicates names" $ do + let init = Tree L.empty + let tree2 = registerLayer ["LeagueOfGentlemenAdventurers", "The Stranger"] init + let tree3 = registerLayer ["JusticeUnion", "TomTomorrow"] tree2 + let tree4 = registerLayer ["HomeTeam", "DocRocket"] tree3 + let tree5 = registerLayer ["JusticeUnion", "TheOgre"] tree4 + + layerPath ["JusticeUnion", "TheOgre"] tree5 `shouldBe` [2, 2] + layerPath ["HomeTeam"] tree5 `shouldBe` [3] + layerPath ["LeagueOfGentlemenAdventurers"] tree5 `shouldBe` [1] + uniqueName ["HomeTeam"] tree5 `shouldBe` ["HomeTeam", "1"] styleIndex :: StyleIndex styleIndex = new -- 2.30.2