{-# LANGUAGE OverloadedStrings #-}
-- | Evaluates CSS selectors over an element.
-- INTERNAL MODULE.
module Data.CSS.Style.Selector.Interpret(
        compile, SelectorFunc,
        InterpretedRuleStore(..)
    ) where

import Data.CSS.Style.Common

import Data.Text (unpack)
import Data.List
import Data.Maybe
import Data.Bits (xor)

-- For pseudoclasses
import Data.CSS.Syntax.Selector (parseSelectors)

-- | A compiled(?) CSS selector.
type SelectorFunc = Element -> Bool
type AttrsFunc = [Attribute] -> Bool
-- Mostly here for the sake of pseudoclasses.
data IL = Tagname Text | Fail | Recursive Bool [Selector]

-- | Converts a parsed CSS selector into a callable function.
compile :: Selector -> SelectorFunc
compile (Element sel) = compileInner sel
compile (Child upSel sel) = direct parent (compile upSel) $ compileInner sel
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 :: [SimpleSelector] -> SelectorFunc
compileInner sel = compileInner' $ lowerInner sel
compileInner' :: ([IL], [(Text, String -> Bool)]) -> SelectorFunc
compileInner' ((Tagname tag:tests), attrs) = testTag tag $ compileInner' (tests, attrs)
compileInner' ((Fail:_), _) = \_ -> False
compileInner' ((Recursive negate' sels:tests), attrs) =
    recursiveSelect negate' (map compile sels) $ compileInner' (tests, attrs)
compileInner' ([], attrs) = testAttrs (compileAttrs $ sortAttrs attrs) matched
compileAttrs :: [(Text, String -> Bool)] -> AttrsFunc
compileAttrs ((tag, test):attrs) = testAttr tag test $ compileAttrs attrs
compileAttrs [] = matched

lowerInner :: [SimpleSelector] -> ([IL], [(Text, String -> Bool)])
lowerInner (Tag tag:sel) = (Tagname tag:tests, attrs) where (tests, attrs) = lowerInner sel
lowerInner (Id i:s) = (tests, ("id", hasWord $ unpack i):attrs) where (tests, attrs) = lowerInner s
lowerInner (Class c:s) = (tests, ("class", hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s
lowerInner (Property prop test:s) = (tests, (prop, compileAttrTest test):attrs)
    where (tests, attrs) = lowerInner s
-- psuedos, TODO handle argumented psuedoclasses.
lowerInner (Psuedoclass c args:s)
    | c `elem` ["is", "where"], (sels, []) <- parseSelectors args =
        (Recursive False sels:tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass "not" args:s) | (sels, []) <- parseSelectors args =
    (Recursive True sels:tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass c []:s) =
    (tests, ("", hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass _ _:_) = ([Fail], [])
lowerInner [] = ([], [])

compileAttrTest :: PropertyTest -> String -> Bool
compileAttrTest Exists = matched
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 :: [(Text, b)] -> [(Text, b)]
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 :: (Element -> Maybe Element) -> SelectorFunc -> SelectorFunc -> SelectorFunc
direct traverser upTest test el | Just up <- traverser el = test el && upTest up
    | 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 :: t -> Bool
matched _ = True

testAttr :: Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc
testAttr expected test next attrs@(Attribute attr value : attrs')
    | attr < expected = testAttr expected test next attrs'
    | attr > expected = False
    | attr == expected && test value = next attrs
    | otherwise = False
testAttr _ _ _ [] = False

hasWord :: String -> String -> Bool
hasWord expected value = expected `elem` words value
hasLang :: [Char] -> [Char] -> Bool
hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value

--- Pseudoclasses
recursiveSelect :: Bool -> [SelectorFunc] -> SelectorFunc -> SelectorFunc
recursiveSelect negate' sels success el | negate' `xor` any ($ el) sels = success el
    | otherwise = False

--------
---- RuleStore wrapper
--------
-- | Compiles & fully evaluates CSS selectors.
data InterpretedRuleStore inner = InterpretedRuleStore inner
instance RuleStore inner => RuleStore (InterpretedRuleStore inner) where
    new = InterpretedRuleStore new
    addStyleRule (InterpretedRuleStore self) priority rule =
        InterpretedRuleStore $ addStyleRule self priority $ rule {
            compiledSelector = compile $ selector rule
        }
    lookupRules (InterpretedRuleStore self) el = filter call $ lookupRules self el
        where call (StyleRule' _ test _) = test el