{-# LANGUAGE OverloadedStrings #-}
-- | Lowers psuedoclasses to rawer syntactic forms.
module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..),
psuedoClassesFilter, htmlPsuedoFilter,
addRewrite, addRewrite', addPsuedoEl, addNamespace) where
import Data.CSS.Syntax.StyleSheet
import Data.CSS.Syntax.Selector
import Data.CSS.Syntax.Tokens
import Data.Text as Txt
import Data.Maybe (fromMaybe)
import Data.HashMap.Lazy as HM
import Data.Function ((&))
--------
---- core
--------
data LowerPsuedoClasses s = LowerPsuedoClasses {
inner :: s,
rewriteRules :: HashMap Text [Token],
psuedoEls :: [Text],
namespaces :: HashMap Text Text
}
instance StyleSheet s => StyleSheet (LowerPsuedoClasses s) where
setPriority p self = self { inner = setPriority p $ inner self }
addRule self rule = self { inner = addRule (inner self) $ lowerRule self rule }
addAtRule self "namespace" (Ident ns:toks) | (Url url:toks') <- skipSpace toks =
(addNamespace ns url self, toks')
addAtRule self name toks = let (inner', toks') = addAtRule (inner self) name toks
in (self { inner = inner' }, toks')
lowerRule :: LowerPsuedoClasses t -> StyleRule -> StyleRule
lowerRule self@(LowerPsuedoClasses { psuedoEls = psuedos }) (StyleRule sel props "")
| Just pseudo <- extractPseudoEl psuedos sel =
lowerRule (addRewrite' pseudo [] self) $ StyleRule sel props pseudo
lowerRule LowerPsuedoClasses { namespaces = ns, rewriteRules = rewrites } (StyleRule sel props pseudoel) =
StyleRule (lowerSelector ns rewrites sel) props pseudoel
extractPseudoEl :: [Text] -> Selector -> Maybe Text
extractPseudoEl ps (Element sel)
| (pseudo:_) <- [p | Psuedoclass p [] <- sel, p `elem` ps] = Just pseudo
| otherwise = Nothing
extractPseudoEl ps (Child sel _) = extractPseudoEl ps sel
extractPseudoEl ps (Descendant sel _) = extractPseudoEl ps sel
extractPseudoEl ps (Adjacent sel _) = extractPseudoEl ps sel
extractPseudoEl ps (Sibling sel _) = extractPseudoEl ps sel
lowerSelector :: HashMap Text Text -> HashMap Text [Token] -> Selector -> Selector
lowerSelector ns rewrites (Element sel') = Element $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Child p sel') =
Child (lowerSelector ns rewrites p) $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Descendant p sel') =
Descendant (lowerSelector ns rewrites p) $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Adjacent sib sel') =
Adjacent (lowerSelector ns rewrites sib) $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Sibling sib sel') =
Sibling (lowerSelector ns rewrites sib) $ lowerSelector' ns rewrites sel'
lowerSelector' :: HashMap Text Text -> HashMap Text [Token] -> [SimpleSelector] -> [SimpleSelector]
lowerSelector' namespaces' rewrites (Namespace ns:sels) =
Namespace (fromMaybe "about:invalid" $ HM.lookup ns namespaces') : lowerSelector' namespaces' rewrites sels
lowerSelector' ns rewrites (Psuedoclass name []:sels)
| Just value <- name `HM.lookup` rewrites = Psuedoclass "where" value : lowerSelector' ns rewrites sels
lowerSelector' ns rewrites (Psuedoclass name [arg]:sels)
| Just value <- name `HM.lookup` rewrites =
Psuedoclass "where" [if a == Ident "_" then arg else a | a <- value] : lowerSelector' ns rewrites sels
lowerSelector' ns rewrites (sel:sels) = sel : lowerSelector' ns rewrites sels
lowerSelector' _ _ [] = []
--------
---- constructors
--------
psuedoClassesFilter :: StyleSheet s => s -> LowerPsuedoClasses s
psuedoClassesFilter s = LowerPsuedoClasses s HM.empty ["before", "after"] HM.empty
addPsuedoEl :: Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s
addPsuedoEl ps self = self { psuedoEls = psuedoEls self ++ Txt.words ps }
addRewrite :: Text -> Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s
addRewrite name sel self = addRewrite' name (tokenize sel) self
addRewrite' :: Text -> [Token] -> LowerPsuedoClasses s -> LowerPsuedoClasses s
addRewrite' name sel self = self { rewriteRules = insert name sel $ rewriteRules self }
addNamespace :: Text -> Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s
addNamespace ns uri self = self { namespaces = insert ns uri $ namespaces self }
htmlPsuedoFilter :: StyleSheet s => s -> LowerPsuedoClasses s
htmlPsuedoFilter s = psuedoClassesFilter s &
addRewrite "link" "[href]" &
addRewrite "any-link" "[href]" &
addRewrite "blank" "[value=''], :not([value])" &
addRewrite "checked" "[checked]" &
addRewrite "dir" "[dir=_], [dir=_] *" &
addRewrite "disabled" "[disabled]" &
addRewrite "enabled" ":not([disabled])" &
addRewrite "first-child" ":nth-child(1)" &
addRewrite "first-of-type" ":nth-of-type(1)" &
addRewrite "indeterminate" "[indeterminate]" &
addRewrite "lang" "[lang|=_], [lang|=_] *" &
-- Not sure if I ever really want to support these, but might as well list them.
-- Requires more data to be fed to the core CSS engine.
addRewrite "last-child" ":nth-last-child(1)" &
addRewrite "last-of-type" ":nth-last-of-type(1)" &
addRewrite "only-child" ":nth-child(1):nth-last-child(1)" &
addRewrite "only-of-type" ":nth-of-type(1):nth-last-of-type(1)" &
-- No issue with remainder.
addRewrite "optional" ":not([required])" &
addRewrite "placeholder-shown" "[value=''][placeholder], [placeholder]:not([value])" &
addRewrite "readonly" "[readonly], [disabled]" &
addRewrite "read-write" ":not([readonly]):not([disabled])" &
addRewrite "required" "[required]" &
addRewrite "root" "html" &
addRewrite "scope" "html"