From 8492d01f58f80e2a4b251e9dc38cec99128e8e0d Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 16 Jun 2019 16:21:05 +1200
Subject: [PATCH] Implement CSS selector interpretor.

---
 src/Stylish/Element.hs         |  6 ++--
 src/Stylish/Style/Index.hs     |  4 +--
 src/Stylish/Style/Interpret.hs | 66 ++++++++++++++++++++++++++++------
 3 files changed, 62 insertions(+), 14 deletions(-)

diff --git a/src/Stylish/Element.hs b/src/Stylish/Element.hs
index 97cee9c..2416455 100644
--- a/src/Stylish/Element.hs
+++ b/src/Stylish/Element.hs
@@ -2,10 +2,12 @@ module Stylish.Element(
         Element(..), Attribute(..)
     ) where
 
+import Data.Text.Internal (Text(..))
+
 data Element = ElementNode {
     parent :: Maybe Element,
     previous :: Maybe Element,
-    name :: String,
+    name :: Text,
     attributes :: [Attribute] -- in sorted order.
 }
-data Attribute = Attribute String String
+data Attribute = Attribute Text String
diff --git a/src/Stylish/Style/Index.hs b/src/Stylish/Style/Index.hs
index b452cb8..be13520 100644
--- a/src/Stylish/Style/Index.hs
+++ b/src/Stylish/Style/Index.hs
@@ -57,7 +57,7 @@ rulesForElement self element = nub $ Prelude.foldr (++) [] rules
 
 testsForElement :: Element -> [SimpleSelector]
 testsForElement element =
-    (Tag $ pack $ name element) : (testsForAttributes $ attributes element)
+    (Tag $ name element) : (testsForAttributes $ attributes element)
 testsForAttributes (Attribute "class" value:attrs) =
     (Prelude.map (\s -> Class $ pack s) $ words value) ++
         (Property "class" Exists : testsForAttributes attrs)
@@ -65,7 +65,7 @@ testsForAttributes (Attribute "id" value:attrs) =
     (Prelude.map (\s -> Id $ pack s) $ words value) ++
         (Property "id" Exists : testsForAttributes attrs)
 testsForAttributes (Attribute name _:attrs) =
-    Property (pack name) Exists : testsForAttributes attrs
+    Property name Exists : testsForAttributes attrs
 testsForAttributes [] = []
 
 -- Implement hashable for SimpleSelector here because it proved challenging to automatically derive it.
diff --git a/src/Stylish/Style/Interpret.hs b/src/Stylish/Style/Interpret.hs
index 417c897..d034ecb 100644
--- a/src/Stylish/Style/Interpret.hs
+++ b/src/Stylish/Style/Interpret.hs
@@ -4,27 +4,73 @@ module Stylish.Style.Interpret(
     ) where
 
 import Stylish.Parse.Selector
+import Stylish.Element
 
 import Data.Text.Internal (Text(..))
+import Data.Text (unpack)
 import Data.List
+import Data.Maybe
 
-data SelectorFunc = TestTag Text SelectorFunc | TestAttrs AttrsFunc SelectorFunc | Matched
-data AttrsFunc = TestAttr Text PropertyTest AttrsFunc | MatchedAttrs
+type SelectorFunc = Element -> Bool
+type AttrsFunc = [Attribute] -> Bool
 
 compile :: Selector -> SelectorFunc
 compile (Element selector) = compileInner selector
+compile (Child upSelector selector) = direct parent (compile upSelector) $ compileInner selector
+compile (Descendant up sel) = indirect parent (compile up) $ compileInner sel
+compile (Adjacent up sel) = direct previous (compile up) $ compileInner sel
+compile (Sibling up sel) = indirect previous (compile up) $ compileInner sel
 
 compileInner selector = compileInner' $ lowerInner selector
-compileInner' (Just tag, attributes) = TestTag tag $ TestAttrs (compileAttrs $ sortAttrs attributes) Matched
-compileInner' (Nothing, attributes) = TestAttrs (compileAttrs $ sortAttrs attributes) Matched
-compileAttrs ((name, test):attrs) = TestAttr name test $ compileAttrs attrs
-compileAttrs [] = MatchedAttrs
+compileInner' :: (Maybe Text, [(Text, String -> Bool)]) -> SelectorFunc
+compileInner' (Just tag, attributes) = testTag tag $ testAttrs (compileAttrs $ sortAttrs attributes) matched
+compileInner' (Nothing, attributes) = testAttrs (compileAttrs $ sortAttrs attributes) matched
+compileAttrs :: [(Text, String -> Bool)] -> AttrsFunc
+compileAttrs ((name, test):attrs) = testAttr name test $ compileAttrs attrs
+compileAttrs [] = matched
 
-lowerInner :: [SimpleSelector] -> (Maybe Text, [(Text, PropertyTest)])
 lowerInner (Tag tag:selector) = (Just tag, snd $ lowerInner selector)
-lowerInner (Id id:s) = (tag, ("id", Include id):tail) where (tag, tail) = lowerInner s
-lowerInner (Class c:s) = (tag, ("class", Include c):tail) where (tag, tail) = lowerInner s
-lowerInner (Property name test:s) = (tag, (name, test):tail) where (tag, tail) = lowerInner s
+lowerInner (Id id:s) = (tag, ("id", hasWord $ unpack id):tail) where (tag, tail) = lowerInner s
+lowerInner (Class c:s) = (tag, ("class", hasWord $ unpack c):tail) where (tag, tail) = lowerInner s
+lowerInner (Property name test:s) = (tag, (name, compileAttrTest test):tail)
+    where (tag, tail) = lowerInner s
 lowerInner [] = (Nothing, [])
 
+compileAttrTest (Equals val) = (== (unpack val))
+compileAttrTest (Suffix val) = isSuffixOf $ unpack val
+compileAttrTest (Prefix val) = isPrefixOf $ unpack val
+compileAttrTest (Substring val) = isInfixOf $ unpack val
+compileAttrTest (Include val) = hasWord $ unpack val
+compileAttrTest (Dash val) = hasLang $ unpack val
+
 sortAttrs = sortBy compareAttrs where compareAttrs x y = fst x `compare` fst y
+
+--------
+---- Runtime
+--------
+testTag :: Text -> SelectorFunc -> SelectorFunc
+testTag tag success el | name el == tag = success el
+    | otherwise = False
+testAttrs :: AttrsFunc -> SelectorFunc -> SelectorFunc
+testAttrs attrsTest success el | attrsTest $ attributes el = success el
+    | otherwise = False
+direct traverser upTest test el
+    | Just parent <- traverser el = test el && upTest parent
+    | otherwise = False
+indirect :: (Element -> Maybe Element) -> SelectorFunc -> SelectorFunc -> SelectorFunc
+indirect traverser upTest test el | Nothing <- traverser el = False
+    | not $ test el = False
+    | upTest (fromJust $ traverser el) = True
+    | otherwise = indirect traverser upTest test $ fromJust $ traverser el
+matched _ = True
+
+testAttr :: Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc
+testAttr expected test next attrs@(Attribute name value : attrs')
+    | name < expected = testAttr expected test next attrs'
+    | name > expected = False
+    | name == expected && test value = next attrs
+    | otherwise = False
+testAttr _ _ _ [] = False
+
+hasWord expected value = expected `elem` words value
+hasLang _ _ = False -- TODO add support for this.
-- 
2.30.2