simple-css 0.0.3 → 0.0.4
raw patch · 3 files changed
+58/−41 lines, 3 filesdep +hashabledep +unordered-containersdep −containersdep ~blaze-htmldep ~language-css
Dependencies added: hashable, unordered-containers
Dependencies removed: containers
Dependency ranges changed: blaze-html, language-css
Files
- simple-css.cabal +4/−2
- src/SimpleCss.hs +46/−36
- src/SimpleCss/Tricks/Shortcuts/Html.hs +8/−3
simple-css.cabal view
@@ -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
src/SimpleCss.hs view
@@ -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)-
src/SimpleCss/Tricks/Shortcuts/Html.hs view
@@ -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