diff --git a/simple-css.cabal b/simple-css.cabal --- a/simple-css.cabal +++ b/simple-css.cabal @@ -1,5 +1,5 @@ Name: simple-css -Version: 0.0.3 +Version: 0.0.4 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE @@ -24,7 +24,9 @@ Library Build-Depends: - base >= 4, base < 5, containers == 0.*, language-css == 0.0.1, blaze-html >= 0.3.0.1 + base >= 4, base < 5, + unordered-containers >= 0.1.1, hashable >= 1.1.1.0, + language-css >= 0.0.2, blaze-html >= 0.4 Hs-Source-Dirs: src/ Exposed-Modules: SimpleCss diff --git a/src/SimpleCss.hs b/src/SimpleCss.hs --- a/src/SimpleCss.hs +++ b/src/SimpleCss.hs @@ -8,7 +8,8 @@ dot, pseudo, context, -- * Render - HtmlSpec(..), renderCss, toBlaze + HtmlSpec(..), + renderCss, toBlaze ) where @@ -17,13 +18,16 @@ import Data.Ord import Data.Function -import qualified Data.Map as M +--import qualified Data.Map as M +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 -- Types @@ -50,7 +54,7 @@ { ruleDecl :: [Decl] , ruleCtx :: Context , rulePseudo :: Pseudo - } + } deriving (Eq) -- Constructors @@ -118,14 +122,14 @@ -- | render css -- -- returns string of css code and list of htmls -renderCss :: HtmlSpec a -> [Css a] -> (CssCode, [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 -- | render css for blaze-html -toBlaze :: [Css H.Html] -> (CssCode, [H.Html]) +toBlaze :: [Css H.Html] -> ([RuleSet], [H.Html]) toBlaze = renderCss blazeSpec blazeSpec = HtmlSpec @@ -145,25 +149,36 @@ deriving (Show, Eq, Ord) type ClassId = String -type ClassTable = M.Map [RuleCode] (ClassId, [RuleType]) +type ClassTable = H.HashMap Rule ClassId data CssTag a = DivTag | SpanTag | ATag Href | Prim a type RuleCode = String -type CssDecl = [(RuleType, RuleCode)] -data CssNode a = CssNode (CssTag a) [[RuleCode]] +data CssNode a = CssNode (CssTag a) [Rule] data TagTree a = TagTree (CssNode a) [TagTree a] type CssCode = String -code :: Rule -> [RuleCode] -code r = case rulePseudo r of - [] -> return $ show $ sel $ ruleDecl r - xs -> [ show $ (sel /: ps) ds | (ps, ds) <- xs ] - where sel = foldl1 (/-) $ star : (map ident $ ruleCtx r) +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 + +-- class names table +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 @@ -177,20 +192,20 @@ PIdent (Ident "visited") -> Visited PIdent (Ident "hover") -> Hover PIdent (Ident "active") -> Active - _ -> Simple + _ -> Simple -- declarations -getCssDecls :: [Css a] -> [CssDecl] +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 CssDecl +getCssDeclFromTree :: Css a -> Maybe Rule getCssDeclFromTree x = case x of - Style r _ -> Just $ zip (ruleType r) (code r) + Style r _ -> Just r _ -> Nothing @@ -221,36 +236,31 @@ Style _ a -> getTag a -getRuleCode :: Css a -> [[RuleCode]] +getRuleCode :: Css a -> [Rule] getRuleCode x = case x of - Style r x -> code r : getRuleCode x + Style r x -> r : getRuleCode x _ -> [] --- class names table -classTable :: [CssDecl] -> ClassTable -classTable = M.fromList . zipWith phi ids . nubOn snd . map unzip - where ids = map (('c' : ). show) [0 ..] - phi id (a, b) = (b, (id, a)) - +-- print ruleSets +ppRuleSets :: ClassTable -> [RuleSet] +ppRuleSets = ((uncurry $ flip toRuleSet) =<< ) + . sortOn snd . H.toList -nubOn f = nubBy ((==) `on` f) -sortOn f = sortBy (compare `on` f) --- print ruleSets -ppRuleSets :: ClassTable -> String -ppRuleSets = - unlines . map snd . sortOn fst . (shape =<< ) . M.toList - where shape (names, (id, types)) = zip types $ map (setClass id) names +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) -setClass :: ClassId -> String -> String -setClass id str = ('.' : ) $ id ++ tail str -- print html ppHtml :: HtmlSpec a -> ClassTable -> TagTree a -> a ppHtml spec table (TagTree (CssNode tag rules) xs) = setAttrs spec attrs next - where attrs = map (fst . (table M.! )) rules + where attrs = map (maybe [] id . flip H.lookup table) rules next = case tag of Prim a -> a DivTag -> divTag spec next' @@ -258,9 +268,9 @@ 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) - diff --git a/src/SimpleCss/Tricks/Shortcuts/Html.hs b/src/SimpleCss/Tricks/Shortcuts/Html.hs --- a/src/SimpleCss/Tricks/Shortcuts/Html.hs +++ b/src/SimpleCss/Tricks/Shortcuts/Html.hs @@ -6,6 +6,7 @@ where import Language.Css.Syntax +import Language.Css.Pretty import Language.Css.Build import SimpleCss @@ -140,12 +141,16 @@ -- * global css StyleSheet i.e. ruleSets about @body@ or some html elements -- -- * list of ((filename, html head sub elements), css) -writeBlazeCss :: String -> StyleSheet -> [((String, H.Html), Css H.Html)] -> IO () -writeBlazeCss cssFile globalStyles xs = writeFile cssFile (gCssCont ++ cssCont) >> +writeBlazeCss :: + String -> StyleSheet + -> [((String, H.Html), Css H.Html)] -> IO () +writeBlazeCss cssFile globalStyles xs = + writeFile cssFile (prettyPrint $ merge globalStyles cssCont) >> (foldl1 (>>) $ zipWith writeFile (map (fst . fst) xs) $ zipWith (formHtml cssFile) (map (snd . fst) xs) htmls) where (cssCont, htmls) = toBlaze $ map snd xs - gCssCont = show globalStyles ++ "\n\n" + merge (StyleSheet h0 h1 body) x = StyleSheet h0 h1 + $ body ++ map SRuleSet x formHtml :: String -> H.Html -> H.Html -> String