From ccae6742380a71fa0037bc8c9ff40474768c3783 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 15 Jul 2019 14:29:26 +1200 Subject: [PATCH] Improve code cleanliness to avoid future bugs. --- src/Data/CSS/Style/Selector/Index.hs | 14 +++++++++----- src/Data/CSS/Syntax/Selector.hs | 17 ++++++++++++++--- src/Data/CSS/Syntax/StylishUtil.hs | 10 +++++++++- stylish-haskell.cabal | 3 +++ 4 files changed, 35 insertions(+), 9 deletions(-) diff --git a/src/Data/CSS/Style/Selector/Index.hs b/src/Data/CSS/Style/Selector/Index.hs index ff9e7db..b9c5cf1 100644 --- a/src/Data/CSS/Style/Selector/Index.hs +++ b/src/Data/CSS/Style/Selector/Index.hs @@ -35,18 +35,21 @@ rulesForElement self element = Prelude.map inner $ lookupRules self element --- +simpleSelector :: Selector -> [SimpleSelector] simpleSelector (Element s) = s simpleSelector (Child _ s) = s simpleSelector (Descendant _ s) = s simpleSelector (Adjacent _ s) = s simpleSelector (Sibling _ s) = s -addRuleForSelector self@(StyleIndex index _) rule selector - | Just key <- selectorKey selector = self { +addRuleForSelector :: StyleIndex -> StyleRule' -> [SimpleSelector] -> StyleIndex +addRuleForSelector self@(StyleIndex index _) rule sel + | Just key <- selectorKey sel = self { indexed = insert key (rule : lookup' key index) index } | otherwise = self {unindexed = rule : unindexed self} +selectorKey :: [SimpleSelector] -> Maybe SimpleSelector selectorKey (tok@(Tag _) : _) = Just tok selectorKey (tok@(Id _) : _) = Just tok selectorKey (tok@(Class _) : _) = Just tok @@ -56,6 +59,7 @@ selectorKey [] = Nothing ---- +testsForAttributes :: [Attribute] -> [SimpleSelector] testsForElement :: Element -> [SimpleSelector] testsForElement element = (Tag $ name element) : (testsForAttributes $ attributes element) @@ -65,14 +69,14 @@ testsForAttributes (Attribute "class" value:attrs) = testsForAttributes (Attribute "id" value:attrs) = (Prelude.map (\s -> Id $ pack s) $ words value) ++ (Property "id" Exists : testsForAttributes attrs) -testsForAttributes (Attribute name _:attrs) = - Property name Exists : testsForAttributes attrs +testsForAttributes (Attribute elName _:attrs) = + Property elName Exists : testsForAttributes attrs testsForAttributes [] = [] -- Implement hashable for SimpleSelector here because it proved challenging to automatically derive it. instance Hashable SimpleSelector where hashWithSalt seed (Tag tag) = seed `hashWithSalt` (0::Int) `hashWithSalt` unpack tag - hashWithSalt seed (Id id) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack id + hashWithSalt seed (Id i) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack i hashWithSalt seed (Class class_) = seed `hashWithSalt` (2::Int) `hashWithSalt` unpack class_ hashWithSalt seed (Property prop test) = seed `hashWithSalt` (3::Int) `hashWithSalt` unpack prop `hashWithSalt` test diff --git a/src/Data/CSS/Syntax/Selector.hs b/src/Data/CSS/Syntax/Selector.hs index 9580f98..aa8fc7c 100644 --- a/src/Data/CSS/Syntax/Selector.hs +++ b/src/Data/CSS/Syntax/Selector.hs @@ -19,31 +19,39 @@ data PropertyTest = Exists | Equals Text | Suffix Text | Prefix Text | Substring Include Text | Dash Text deriving (Show, Eq) -parseSelectors :: [Token] -> ([Selector], [Token]) +parseSelectors :: Parser [Selector] parseSelectors tokens = concatP (:) parseCompound parseSelectorsTail $ skipSpace tokens +parseSelectorsTail :: Parser [Selector] parseSelectorsTail (Comma:tokens) = parseSelectors tokens parseSelectorsTail tokens = ([], tokens) +parseCompound :: Parser Selector parseCompound tokens = parseCombinators (Element selector) tokens' where (selector, tokens') = parseSelector tokens +parseSelector' :: SimpleSelector -> Parser [SimpleSelector] parseSelector' op tokens = (op:selector, tokens') where (selector, tokens') = parseSelector tokens +parseSelector :: Parser [SimpleSelector] parseSelector (Delim '*':tokens) = parseSelector tokens parseSelector (Ident tag:tokens) = parseSelector' (Tag tag) tokens -parseSelector (Hash _ id:tokens) = parseSelector' (Id id) tokens +parseSelector (Hash _ i:tokens) = parseSelector' (Id i) tokens parseSelector (Delim '.':Ident class_:tokens) = parseSelector' (Class class_) tokens parseSelector (LeftSquareBracket:Ident prop:tokens) = concatP appendPropertySel parsePropertySel parseSelector tokens where appendPropertySel test selector = Property prop test : selector parseSelector tokens = ([], tokens) +parseCombinators' :: Selector -> Parser Selector parseCombinators' selector tokens = parseCombinators selector' tokens' where (selector', tokens') = parseCombinator selector tokens +parseCombinators :: Selector -> Parser Selector parseCombinators selector (Whitespace:tokens) = parseCombinators' selector tokens -parseCombinators selector tokens@(Delim c:_) = parseCombinators' selector tokens +parseCombinators selector tokens@(Delim _:_) = parseCombinators' selector tokens parseCombinators selector tokens = (selector, tokens) +parseCombinator' :: (Selector -> [SimpleSelector] -> Selector) + -> Selector -> Parser Selector parseCombinator' cb selector tokens = (cb selector selector', tokens') where (selector', tokens') = parseSelector $ skipSpace tokens parseCombinator :: Selector -> [Token] -> (Selector, [Token]) @@ -62,6 +70,7 @@ parseCombinator selector [] = (selector, []) parseCombinator selector tokens = parseCombinator' Descendant selector tokens +parsePropertySel :: Parser PropertyTest parsePropertySel (RightSquareBracket:tokens) = (Exists, tokens) parsePropertySel (Delim '=':tokens) = parsePropertyVal (Equals) tokens parsePropertySel (SuffixMatch:tokens) = parsePropertyVal (Suffix) tokens @@ -71,5 +80,7 @@ parsePropertySel (IncludeMatch:tokens) = parsePropertyVal (Include) tokens parsePropertySel (DashMatch:tokens) = parsePropertyVal (Dash) tokens parsePropertySel tokens = (Exists, skipBlock tokens) +parsePropertyVal :: (Text -> PropertyTest) -> Parser PropertyTest parsePropertyVal wrapper (Ident val:RightSquareBracket:tokens) = (wrapper val, tokens) parsePropertyVal wrapper (String val:RightSquareBracket:tokens) = (wrapper val, tokens) +parsePropertyVal _ tokens = (Exists, skipBlock tokens) diff --git a/src/Data/CSS/Syntax/StylishUtil.hs b/src/Data/CSS/Syntax/StylishUtil.hs index 2441a22..8af8684 100644 --- a/src/Data/CSS/Syntax/StylishUtil.hs +++ b/src/Data/CSS/Syntax/StylishUtil.hs @@ -1,22 +1,28 @@ module Data.CSS.Syntax.StylishUtil( concatP, capture, skipSpace, - scanBlock, skipBlock, scanInner + scanBlock, skipBlock, scanInner, + Parser ) where import Data.CSS.Syntax.Tokens +type Parser x = [Token] -> (x, [Token]) +concatP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c concatP join left right tokens = (join x y, remainder) where (x, tokens') = left tokens (y, remainder) = right tokens' +capture :: Parser [Token] -> Parser [Token] capture cb (token:tokens) = (token:captured, tokens') where (captured, tokens') = cb tokens capture _ [] = ([], []) +skipSpace :: [Token] -> [Token] skipSpace (Whitespace:tokens) = skipSpace tokens skipSpace tokens = tokens +scanBlock :: Parser [Token] -- TODO assert closing tags are correct -- But what should the error recovery be? scanBlock (RightCurlyBracket:tokens) = ([RightCurlyBracket], tokens) @@ -30,8 +36,10 @@ scanBlock tokens@(LeftSquareBracket:_) = scanInner tokens scanBlock scanBlock tokens = capture scanBlock tokens +skipBlock :: [Token] -> [Token] skipBlock tokens = snd $ scanBlock tokens +scanInner :: [Token] -> Parser [Token] -> ([Token], [Token]) scanInner (token:tokens) cb = concatP gather scanBlock cb tokens where gather x y = token : x ++ y scanInner [] _ = error "Expected a token to capture." diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index e22e078..2cb0e9c 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -66,6 +66,8 @@ library -- Base language which the package is written in. default-language: Haskell2010 + + ghc-options: -Wall test-suite test-stylish hs-source-dirs: src test @@ -74,3 +76,4 @@ test-suite test-stylish main-is: Test.hs other-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style build-depends: base >=4.9 && <4.10, css-syntax, text, unordered-containers, hashable, hspec, QuickCheck + ghc-options: -Wall -- 2.30.2