module SimpleCss(
Css, CssCode, Href, Tag, Pseudo, Context,
prim, hcat, vcat, acat, div', span', a',
dot, pseudo, context,
HtmlSpec(..),
renderCss, toBlaze
)
where
import Data.List
import Data.Maybe
import Data.Ord
import Data.Function
import Data.Hashable
import qualified Data.HashMap.Lazy as H
import qualified Text.Blaze as H
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Language.Css.Syntax
import Language.Css.Pretty
import Language.Css.Build
data Css a = Elem a
| Div [Css a]
| Span [Css a]
| A Href [Css a]
| Style Rule (Css a)
type Href = String
type Tag = String
type Context = [Tag]
type Pseudo = [(PseudoVal, [Decl])]
data Rule = Rule
{ ruleDecl :: [Decl]
, ruleCtx :: Context
, rulePseudo :: Pseudo
} deriving (Eq)
prim :: a -> Css a
prim = Elem
vcat :: [Css a] -> Css a
vcat = Div
hcat :: [Css a] -> Css a
hcat = Span
acat :: Href -> [Css a] -> Css a
acat = A
div' :: Css a -> Css a
div' = vcat . return
span' :: Css a -> Css a
span' = hcat . return
a' :: Href -> Css a -> Css a
a' href = acat href . return
style :: [Decl] -> Context -> Pseudo -> Css a -> Css a
style ds ctx ps = Style (Rule ds ctx ps)
dot :: [Decl] -> Css a -> Css a
dot ds = style ds [] []
pseudo :: Pseudo -> Css a -> Css a
pseudo ps = style [] [] ps
context :: Context -> [Decl] -> Css a -> Css a
context ctx ds = style ds ctx []
data HtmlSpec a = HtmlSpec
{ divTag :: [a] -> a
, spanTag :: [a] -> a
, aTag :: Href -> [a] -> a
, classAttr :: String -> a -> a
}
renderCss :: HtmlSpec a -> [Css a] -> ([RuleSet], [a])
renderCss spec xs =
(ppRuleSets table, map (ppHtml spec table . tagTree) xs)
where decls = getCssDecls =<< map return xs
table = classTable decls
toBlaze :: [Css H.Html] -> ([RuleSet], [H.Html])
toBlaze = renderCss blazeSpec
blazeSpec = HtmlSpec
(blazeTag H.div)
(blazeTag H.span)
(\href -> blazeTag (H.a H.! HA.href (H.stringValue href)))
(\s x -> x H.! HA.class_ (H.stringValue s))
blazeTag tag xs
| null xs = tag $ H.string ""
| otherwise = tag $ foldl1 (>>) xs
data RuleType = Simple | Link | Visited | Hover | Active
deriving (Show, Eq, Ord)
type ClassId = String
type ClassTable = H.HashMap Rule ClassId
data CssTag a = DivTag | SpanTag | ATag Href | Prim a
type RuleCode = String
data CssNode a = CssNode (CssTag a) [Rule]
data TagTree a = TagTree (CssNode a) [TagTree a]
type CssCode = String
instance Hashable Rule where
hash (Rule a b c) = hash (a, b, c)
instance Hashable Decl where
hash = hash . show . pretty
instance Hashable PseudoVal where
hash = hash . show . pretty
classTable :: [Rule] -> ClassTable
classTable = H.fromList . flip zip ids . nub
where ids = map (('c' : ). show) [0 ..]
phi id (a, b) = (b, (id, a))
nubOn f = nubBy ((==) `on` f)
sortOn f = sortBy (compare `on` f)
ruleType :: Rule -> [RuleType]
ruleType r =
case rulePseudo r of
[] -> [Simple]
xs -> map (pseudoType . fst) xs
pseudoType :: PseudoVal -> RuleType
pseudoType x =
case x of
PIdent (Ident "link") -> Link
PIdent (Ident "visited") -> Visited
PIdent (Ident "hover") -> Hover
PIdent (Ident "active") -> Active
_ -> Simple
getCssDecls :: [Css a] -> [Rule]
getCssDecls x =
case x of
[] -> []
xs -> res xs ++ getCssDecls (children =<< xs)
where res xs = (catMaybes $ map getCssDeclFromTree xs)
getCssDeclFromTree :: Css a -> Maybe Rule
getCssDeclFromTree x =
case x of
Style r _ -> Just r
_ -> Nothing
children :: Css a -> [Css a]
children x =
case x of
Elem a -> []
A _ xs -> xs
Div xs -> xs
Span xs -> xs
Style _ x -> [x]
tagTree :: Css a -> TagTree a
tagTree x = TagTree (CssNode t rc) $ map tagTree xs
where rc = getRuleCode x
(t, xs) = getTag x
getTag :: Css a -> (CssTag a, [Css a])
getTag x =
case x of
Elem a -> (Prim a, [])
A href xs -> (ATag href, xs)
Div xs -> (DivTag, xs)
Span xs -> (SpanTag, xs)
Style _ a -> getTag a
getRuleCode :: Css a -> [Rule]
getRuleCode x =
case x of
Style r x -> r : getRuleCode x
_ -> []
ppRuleSets :: ClassTable -> [RuleSet]
ppRuleSets = ((uncurry $ flip toRuleSet) =<< )
. sortOn snd . H.toList
toRuleSet :: String -> Rule -> [RuleSet]
toRuleSet className r = case rulePseudo r of
[] -> return $ sel $ ruleDecl r
xs -> [(sel /: ps) ds | (ps, ds) <- xs ]
where sel = foldl1 (/-) $ (star /. className)
: (map ident $ ruleCtx r)
ppHtml :: HtmlSpec a -> ClassTable -> TagTree a -> a
ppHtml spec table (TagTree (CssNode tag rules) xs) =
setAttrs spec attrs next
where attrs = map (maybe [] id . flip H.lookup table) rules
next = case tag of
Prim a -> a
DivTag -> divTag spec next'
SpanTag -> spanTag spec next'
ATag href -> aTag spec href next'
next' = map (ppHtml spec table) xs
setAttrs :: HtmlSpec a -> [String] -> (a -> a)
setAttrs spec attrs
| null attrs = id
| otherwise = classAttr spec (unwords attrs)