packages feed

simple-css (empty) → 0.0.1

raw patch · 11 files changed

+1339/−0 lines, 11 filesdep +basedep +blaze-htmldep +containerssetup-changed

Dependencies added: base, blaze-html, containers, language-css

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Kholomiov 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Anton Kholomiov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ example/Main.hs view
@@ -0,0 +1,148 @@+import Language.Css.Syntax+import Language.Css.Build++import qualified Language.Css.Build.Idents as C++import SimpleCss+import SimpleCss.Tricks++import Text.Blaze (Html)+import Control.Applicative++import Data.Char++-- generates litle blog-site in current directory+--+-- css.css  - css file+--+-- Home.html, Blog.html, About.html, Contact.html - pages++---------------------------------------------------+--+-- parameters++-- colors ++globalBkgCol = white -- cword "#b6ceff"+homeCol   = black --  cword "#1936ca"+blogCol   = blue -- cword "#4d67d8"+aboutCol  = red -- cword "#9db1ec"+contactCol = green -- cword "#e2f1fe"+menuTextCol = white ++-- borders++bttnBordWidth = px 25+++----------------------------------------------------+-- pages++data Page = Home | Blog | About | Contact+        deriving (Show)++pageColor :: Page -> Expr+pageColor x = +    case x of+        Home -> homeCol+        Blog -> blogCol+        About -> aboutCol+        Contact -> contactCol++pageLink :: Page -> String+pageLink = ( ++ ".html") . show ++titles = map show pages+pages  = [Home, Blog, About, Contact]++------------------------------------------------------+-- elements++-- menu++menus :: [Page] -> [Css Html]+menus = tabs vmenu <$> map (box . activeBttn) +                   <*> map (box . passiveBttn) +                   <*> map menuLinks +    +menuLinks :: Page -> Css Html+menuLinks = a <$> pageLink <*> map toLower . show++activeBttn :: Page -> [Decl]+activeBttn x = border [left] C.solid bttnBordWidth (pageColor x) +            ++ bttn (pageColor x) x++passiveBttn :: Page -> [Decl]+passiveBttn = bttn globalBkgCol++bttn :: Expr -> Page -> [Decl]+bttn col x = border [right] C.solid bttnBordWidth col +          ++ padding sides (px 10)+          ++ brick menuTextCol (pageColor x)++-- header+        +pageHeader :: Page -> Css Html+pageHeader x = dot ([C.textAlign <:> C.center] +            ++ (color $ pageColor x)) $ h1 $ show x++-- content++pageContent :: Page -> Css Html+pageContent x =+    case x of+        Home -> text 1000+        Blog -> vcat $ zipWith blogItem +                    ["22 september", "13 september", "2 spetember", "26 august"] +                    [500, 1000, 500, 150]+        About -> text 3000+        Contact -> text 10000++blogItem d n = vcat [st $ h3 d, text n]+        where st = dot $ (padding sides $ px 5 ) +                      ++ (brick menuTextCol $ pageColor Blog)  ++text :: Int -> Css Html+text n = dot (padding [bottom] (pct 5) +            ++ margin sides (pct 5)) $ +    p $ take n $ cycle "once upon a text "++-- footer++addFooter :: Expr -> Css a -> Css a -> Css a+addFooter h content footer = vcat [ stCont $ div' $ content, stFooter $ div' footer ]+    where stCont = dot (height (pct 100) ++ [C.minHeight <:> pct 100, C.position <:> C.relative]) +          stFooter = dot (width (pct 100) ++ [C.position <:> C.absolute, C.bottom <:> int 0, C.height <:> h])+++footer x = dot (+           borderNone sides +        ++ margin sides (int 0) +        ++ brick menuTextCol (pageColor x)+        ++ (padding sides $ px 10)) $ p "simple-css : example"+++--------------------------------------------------------------------+-- putting it all together++htmls :: Css Html -> Page -> Css Html+htmls m p = vcat [+                footer p,+                dot ((margin sides $ int 0) ++ borderNone sides) $+                leftContent pct 20 m $ addBorder $ vcat [pageHeader p, pageContent p]]+    where addBorder = dot $ (margin [left] (px 20))++-------------------------------------------------------------------+-- global style sheets++bodyStyle = ruleSets [+    ident "body" $ (margin sides $ int 0) +                ++ (borderNone sides) +                ++  bkgColor globalBkgCol]++-------------------------------------------------------------------+-- printing++res = zipWith htmls (menus pages) pages++main = writeBlazeCss "css.css" bodyStyle $ zip (initHtmls titles) res
+ simple-css.cabal view
@@ -0,0 +1,44 @@+Name:          simple-css+Version:       0.0.1+Cabal-Version: >= 1.2+License:       BSD3+License-file:  LICENSE+Author:	       Anton Kholomiov+Synopsis:      simple binding of css and html +Description:   Library binds css and html. It takes notion of /html for content, css for styling/ to extreme. +               There are functions to build 'styling tree' and html elements can be placed only in the lists of the tree.+               Html elements can be groupped with 'div', 'span' or 'a' tags and styled with subset of css. +               Result of the programm is string of css  code and list of html elements.++               Module "SimpleCss" contains core functions of the library and "SimpleCss.Tricks" translates some+               css tricks i've found in the web. +               +               See 'example/Main.hs' to get started++Stability:     Experimental+Tested-With:   GHC==6.13.1+Build-Type:    Simple+Category:      Web+Maintainer:    <anton.kholomiov@gmail.com>+Extra-Source-Files : example/Main.hs++Library+  Build-Depends:+        base >= 4, base < 5, containers, language-css, blaze-html  +  Hs-Source-Dirs:      src/+  Exposed-Modules:+        SimpleCss+        SimpleCss.Tricks+        SimpleCss.Tricks.Shortcuts.Html+        SimpleCss.Tricks.Shortcuts.Css+        SimpleCss.Tricks.Layouts+        SimpleCss.Tricks.Menus+        SimpleCss.Tricks.Images+++---------------------------------------------------------------------------------- 		+  Other-Modules:++++
+ src/SimpleCss.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE StandaloneDeriving #-}+module SimpleCss( +        -- * Types+        Css, CssCode, Href, Tag, Pseudo, Context,++        -- * Constructors+        prim, hcat, vcat, acat, div', span', a',+        dot, pseudo, context,++        -- * Render+        HtmlSpec(..), renderCss, toBlaze+) +where++import Data.List+import Data.Maybe+import Data.Ord+import Data.Function++import qualified Data.Map as M++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.Build++-- Types++-- | representing Css data type+--+-- Css's parameter is html type+data Css a = Elem a               -- ^ html element+           | Div  [Css a]         -- ^ div groupping+           | Span [Css a]         -- ^ span groupping+           | A    Href [Css a]    -- ^ clickable group+           | Style Rule (Css a)   -- ^ styling+++-- selector :+-- '.'className [tag]* ':'pseudo?++type Href    = String+type Tag     = String+type Context = [Tag]+type Pseudo  = [(PseudoVal, [Decl])]++data Rule = Rule +            { ruleDecl   :: [Decl] +            , ruleCtx    :: Context+            , rulePseudo :: Pseudo+            } ++-- Constructors++-- | html element constructor+prim :: a -> Css a+prim = Elem++-- | @div@ groupping+vcat :: [Css a] -> Css a+vcat = Div ++-- | @span@ groupping+hcat :: [Css a] -> Css a+hcat = Span++-- | @a@ groupping+acat :: Href -> [Css a] -> Css a+acat = A+++-- | vcat for singleton+div' :: Css a -> Css a+div' = vcat . return++-- | hcat for singleton+span' :: Css a -> Css a+span' = hcat . return++-- | acat for singleton+a' :: Href -> Css a -> Css a+a' href = acat href . return++-- | style +style :: [Decl] -> Context -> Pseudo -> Css a -> Css a+style ds ctx ps = Style (Rule ds ctx ps) ++-- | set class +dot :: [Decl] -> Css a -> Css a+dot ds = style ds [] []++-- | set class with pseudo- element/class+pseudo :: Pseudo -> Css a -> Css a+pseudo ps = style [] [] ps++-- | styles descendants+context :: Context -> [Decl] -> Css a -> Css a+context ctx ds = style ds ctx []++-- Render++-- | Html specification+--+-- to render css you should specify html's elements groupping +-- with @a@, @div@ and @span@ tags +-- and way to assign values of @class@ attribute+data HtmlSpec a = HtmlSpec +                 { divTag    :: [a] -> a+                 , spanTag   :: [a] -> a+                 , aTag      :: Href   -> [a] -> a+                 , classAttr :: String -> a -> a+                 }++-- putting it all together++-- | render css+--+-- returns string of css code and list of htmls+renderCss :: HtmlSpec a -> [Css a] -> (CssCode, [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 = 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++-------------------------------------------------------------------------+-- basement++data RuleType = Simple | Link | Visited | Hover | Active+    deriving (Show, Eq, Ord)++type ClassId    = String+type ClassTable = M.Map [RuleCode] (ClassId, [RuleType])++data CssTag a = DivTag | SpanTag | ATag Href | Prim a++type RuleCode  = String+type CssDecl   = [(RuleType, RuleCode)]+data CssNode a = CssNode (CssTag a) [[RuleCode]]++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)+++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++-- declarations+getCssDecls :: [Css a] -> [CssDecl]+getCssDecls x = +    case x of+        [] -> []+        xs -> res xs ++ getCssDecls (children =<< xs)+    where res xs = (catMaybes $ map getCssDeclFromTree xs)++getCssDeclFromTree :: Css a -> Maybe CssDecl+getCssDeclFromTree x = +    case x of  +        Style r _ -> Just $ zip (ruleType r) (code 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]++    +-- tag tree+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 -> [[RuleCode]]+getRuleCode x =+    case x of+        Style r x -> code 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))+ ++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++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+          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)++
+ src/SimpleCss/Tricks.hs view
@@ -0,0 +1,15 @@+module SimpleCss.Tricks (+        module SimpleCss.Tricks.Shortcuts.Html,+        module SimpleCss.Tricks.Shortcuts.Css,+        module SimpleCss.Tricks.Layouts,+        module SimpleCss.Tricks.Menus,+        module SimpleCss.Tricks.Images)+where++import SimpleCss.Tricks.Shortcuts.Html+import SimpleCss.Tricks.Shortcuts.Css+import SimpleCss.Tricks.Layouts+import SimpleCss.Tricks.Menus+import SimpleCss.Tricks.Images++
+ src/SimpleCss/Tricks/Images.hs view
@@ -0,0 +1,66 @@+module SimpleCss.Tricks.Images+    (BkgIm(..), bkgIm, bkgIms, gallery)+where+++import Data.List++import Language.Css.Syntax+import Language.Css.Build+import qualified Language.Css.Build.Idents as C++import SimpleCss++cb = C.clear <:> C.both+fl = C.float <:> C.left+fr = C.float <:> C.right++-- | representing background images+data BkgIm = BkgIm +            { bkgImUrl :: String+            , bkgImRepeat :: Expr+            , bkgImXPos :: Expr+            , bkgImYPos :: Expr                +            }+-- | synonym to 'BkgIm'+--+-- arguments are+--+-- * url+--+-- * repeat property+--+-- * x coordinate+--+-- * y coordinate+bkgIm :: String -> Expr -> Expr -> Expr -> BkgIm+bkgIm = BkgIm++-- | set of background images+--+-- arguments+--+-- * background color+--+-- * list of images+--+-- head of list is on top, then goes second image and etc.+bkgIms :: Expr -> [BkgIm] -> Css a -> Css a+bkgIms col ims = colSt . foldl1 (.) styles+    where styles = map ((\x -> dot x . div')  . fromBkgIm) $ reverse ims+          colSt  = dot [C.backgroundColor <:> col] . div'+++fromBkgIm :: BkgIm -> [Decl]+fromBkgIm x = [+    C.background <:> +        spaces [url $ bkgImUrl x, bkgImRepeat x, bkgImXPos x, bkgImYPos x],+    C.margin <:> int 0,+    C.padding <:> int 0,+    C.display <:> C.table,+    C.width <:> pct 100]++-- | floating gallery of images+gallery :: [Css a] -> Css a+gallery = vcat . (: [dot [cb] $ vcat []]) . vcat . map (dot [fl])+
+ src/SimpleCss/Tricks/Layouts.hs view
@@ -0,0 +1,224 @@+module SimpleCss.Tricks.Layouts (+    -- * width/height    +    (^-), (^|),++    -- * Types+    ColumnWidth(..), totalWidth, colw, toColumnWidth,+   +    -- * Margin layouts+    --+    -- | This layouts are based on setting margins and floating menus +    leftContent, rightContent, leftRightContent,+   +    -- * Liquid layouts+    --+    -- | Tricky floating and nesting. +    --+    -- Requires color and background-color to be set for all columns+    columns        +) ++where++import Data.List++import Language.Css.Syntax+import Language.Css.Build+import qualified Language.Css.Build.Idents as C++import SimpleCss++---------------------------------------------------------+-- style short-cuts++cl = C.clear <:> C.right+cr = C.clear <:> C.left++cb = C.clear <:> C.both+fl = C.float <:> C.left+fr = C.float <:> C.right++pr  = C.position <:> C.relative+l n = C.left  <:> n+r n = C.right <:> n+w n = C.width <:> n+h n = C.height <:> n++mt n = C.marginTop <:> n+mb n = C.marginBottom <:> n++ml n = C.marginLeft <:> n+mr n = C.marginRight <:> n++padt n = C.paddingTop <:> n+padb n = C.paddingBottom <:> n++padl n = C.paddingLeft <:> n+padr n = C.paddingRight <:> n++oh  = C.overflow <:> C.hidden++-- width++-- | setting width in procents+(^-) :: Double -> Css a -> Css a+a ^- b = dot [w $ pct a] b++-- | setting height in procents+(^|) :: Double -> Css a -> Css a+a ^| b = dot [h $ pct a] b+++-------------------------------------------------------------+-- Column Width type++-- | construct list of columnWidth values from list of triplets+toColumnWidth :: [(a, a, a)] -> [ColumnWidth a]+toColumnWidth xs = [ColumnWidth a b c | (a, b, c) <- xs]++-- | short-cut for 'ColumnWidth' constructor+colw :: Num a => a -> a -> a -> ColumnWidth a+colw = ColumnWidth++-- | represents column layout+data ColumnWidth a = ColumnWidth +                    { leftPad  :: a    -- ^ left padding width+                    , midWidth :: a    -- ^ content width +                    , rightPad :: a    -- ^ right padding width+                    } deriving (Show)+++-- | @leftPad + midWidth + rightPad@+totalWidth :: Num a => ColumnWidth a -> a+totalWidth x = midWidth x + leftPad x + rightPad x+++--------------------------------------------------------+-- Margin techniques+++-- | left menu + content + right menu+--+-- arguments are : +--+-- * length constructor+--+-- * left menu column width+--+-- * right menu column width+--+-- * left menu+--+-- * right menu+--+-- * content+leftRightContent :: Num t +        => (t -> Expr) -> t -> t +        -> Css a -> Css a -> Css a -> Css a+leftRightContent leng wLeft wRight left right cont =+    vcat [leftStyle $ div' left, rightStyle $ div' right, contStyle $ div' cont]+    where leftStyle  = sideStyle fl wLeft  leng+          rightStyle = sideStyle fr wRight leng+          contStyle  = vcat . return . dot [+                            ml $ leng wLeft,+                            mr $ leng wRight]+++-- | left menu + content+--+-- arguments are : +--+-- * length constructor+--+-- * left menu column width +--+-- * left menu+--+-- * content+leftContent :: Num t => (t -> Expr) -> t -> Css a -> Css a -> Css a+leftContent = menuContent fl ml++-- | content + right menu+--+-- arguments are : +--+-- * length constructor+--+-- * right menu column width+--+-- * right menu +--+-- * content+rightContent ::  Num t => (t -> Expr) -> t -> Css a -> Css a -> Css a+rightContent = menuContent fr mr++++menuContent :: Num t => Decl -> (Expr -> Decl)+    -> (t -> Expr) -> t -> Css a -> Css a -> Css a+menuContent float margin leng wMenu left cont = vcat [leftStyle $ div' left, contStyle $ div' cont]+    where leftStyle = sideStyle float wMenu leng+          contStyle = vcat . return . dot [ margin $ leng wMenu]                        +++sideStyle float width leng = +    vcat . return . dot [float, w $ leng width]++-----------------------------------------------------------------------------------------+-- Liquid layout++-- | liquid layouts+--+-- Places n-columns, implementation of Matthew James Taylor's liquid layout technique.+--+-- See <http://matthewjamestaylor.com/blog/equal-height-columns-cross-browser-css-no-hacks>+--+-- every columns is wrapped in two divs (inner an outer) and floated, styling is applied+-- to both divs, it makes possible to construct columns of equal height, they look like.+--+-- All inherited properties should be assigned for each column. +--+-- For example if you want to make two columns one is black background and white text and+-- another mirrors colors, you should define colors for BOTH columns. Otherwise one column will+-- spread all over the screen+--+-- >elems = [p text1, p text2]+-- >+-- >decl1 = dot [C.color <:> white, C.backgroundColor <:> black]+-- >decl2 = dot [C.color <:> black, C.backgroundColor <:> white]+-- >ds = [decl1, decl2]+-- > +-- >ws = toColumnWidth [(10, 40, 10), (10, 40, 10)]+-- >+-- >res = columns pct (zip (zip ws ds) elems) +columns :: Num t => (t -> Expr) -> [((ColumnWidth t, Css a -> Css a), Css a)] -> Css a +columns leng a' = vcat $ return $ (foldl1 (.) $ reverse conts) $ vcat $ zipWith ($) cols xs +    where (cws, xs) = unzip a+          cols  = zipWith4 (toCol  leng)   [0 ..] (colShifts cws) (map midWidth cws) st'+          conts = zipWith4 (toCont leng s) [0 ..] (tail ds ++ [0]) (zip xs st') adds+          adds = replicate (length a - 1) [] ++ [[oh]]+          ds   = map totalWidth cws+          s    = sum ds+          (a, st') = unzip [((w, x), st) | ((w, st), x) <- a']+          +++toCol :: Num t => (t -> Expr) -> Int -> t -> t -> (Css a -> Css a) -> (Css a -> Css a)+toCol leng n shift d outerStyle = +    dot [fl, w $ leng d, pr, l $ leng shift, oh] . vcat . return . outerStyle++toCont :: Num t => (t -> Expr) -> t -> Int -> t -> (Css a, Css a -> Css a) -> [Decl] -> (Css a -> Css a)+toCont leng totalWidth n shift (x, outerStyle) adds = outerStyle . dot ( +    [w $ leng totalWidth, fl, pr, r $ leng shift] ++ adds) . vcat . return++++colShifts :: Num a => [ColumnWidth a] -> [a]+colShifts xs = map (globalShift + ) $ zipWith (+) leftShifts rightShifts'+    where globalShift  = sum ds - head ds+          leftShifts   = map leftPad  xs+          rightShifts' = fst $ foldl f ([], 0) $ zipWith (+) leftShifts rightShifts+          rightShifts  = map rightPad xs+          f (res, i) x = (res ++ [i], i + x)+          ds           = map totalWidth xs+
+ src/SimpleCss/Tricks/Menus.hs view
@@ -0,0 +1,90 @@+module SimpleCss.Tricks.Menus+    (hmenu, hmenuRel, vmenu, tabs)+where+++import Data.List++import Language.Css.Syntax+import Language.Css.Build+import qualified Language.Css.Build.Idents as C++import SimpleCss++import SimpleCss.Tricks.Shortcuts.Css++---------------------------------------------------------+-- style short-cuts++cb = C.clear <:> C.both+fl = C.float <:> C.left+fr = C.float <:> C.right++posr = C.position <:> C.relative+posa = C.position <:> C.absolute++l n = C.left  <:> n+r n = C.right <:> n+w n = C.width <:> n+h n = C.height <:> n+++mt n = C.marginTop <:> n+mb n = C.marginBottom <:> n+ml n = C.marginLeft <:> n+mr n = C.marginRight <:> n++pl n = C.paddingLeft <:> n+pr n = C.paddingRight <:> n++oh  = C.overflow <:> C.hidden++dspIB = C.display <:> C.inlineBlock+dspB  = C.display <:> C.block+dspI  = C.display <:> C.inline+dspN  = C.display <:> C.none++-- | making tabs+--+-- arguments+--+-- * menu constructor+--+-- * active style+--+-- * passive style+--+-- * elements+--+-- result+--+-- * list of menus' with different active tabs++tabs :: ([Css a] -> Css a) -> [Box] -> [Box] -> [Css a] -> [Css a]+tabs menu actives passives elems = +    [ menu $ zipWith ($) (st i) elems' | i <- [0 .. n]]+    where stA  = map static actives'+          stP  = zipWith rollOver passives' actives'+          n    = length elems' - 1+          st i = take i stP ++ (stA !! i : drop (i + 1) stP)+          (actives', passives', elems') = unzip3 $ zip3 actives passives elems+++++-- | vertical menu+vmenu :: [Css a] -> Css a+vmenu = vcat . zipWith ($) (map (. div') styles)+    where styles = map dot $ repeat [dspB] ++    +-- | horizontal menu+hmenu :: [Css a] -> Css a+hmenu xs = vcat $ zipWith ($) (map (. div') styles) xs+    where styles = map dot $ repeat [dspIB]+    +-- | relative horizontal menu, everything is forced to equal width +hmenuRel :: [Css a] -> Css a+hmenuRel xs = vcat $ zipWith ($) (map (. div') styles) xs+    where styles = map dot $ repeat [dspIB, w $ pct (100 / n)]+          n = fromInteger $ toInteger $ length xs
+ src/SimpleCss/Tricks/Shortcuts/Css.hs view
@@ -0,0 +1,281 @@+-- | styling shortcuts ++module SimpleCss.Tricks.Shortcuts.Css(+        -- * directions+        --+        -- Directions. +        --+        -- >hor = [left, right]+        -- >ver = [top, right]+        -- >sides = [DAll]+        Dir(..), +        +        -- ** direction constructors+        top, bottom, left, right, hor, ver, sides,+        {-+        -- * position+        --+        -- sets position property to relative, fixed or absolute given+        -- x and y coordinates. +        --+        relPos, fixPos, absPos,+        -}+        -- * floating+        lfloat, rfloat, rclear, lclear, bclear,++        -- * Box model+        +        -- ** border+        BorderStyle, BorderWidth, BorderColor,+        border, borderNone,++        -- ** margin+        margin,++        -- ** padding+        padding,++        -- ** content+        width, height,++        -- * background+        bkgColor, brick, pict,++        -- * Text+        color,++        -- * mouse interaction+        Box, box, ibox, static, rollOver, onMouse+) +where++import Language.Css.Syntax+import Language.Css.Build+import qualified Language.Css.Build.Idents as C++import SimpleCss ++---------------------------------------------------------+-- style short-cuts++cl = C.clear <:> C.right+cr = C.clear <:> C.left++cb = C.clear <:> C.both+fl = C.float <:> C.left+fr = C.float <:> C.right++pr  = C.position <:> C.relative+l n = C.left  <:> n+r n = C.right <:> n+w n = C.width <:> n+h n = C.height <:> n++mt n = C.marginTop <:> n+mb n = C.marginBottom <:> n++ml n = C.marginLeft <:> n+mr n = C.marginRight <:> n++padt n = C.paddingTop <:> n+padb n = C.paddingBottom <:> n++padl n = C.paddingLeft <:> n+padr n = C.paddingRight <:> n++----------------------------------------------------++-- position+{-+setPos :: (Num t, Ord t) => Expr -> (t -> Expr) -> t -> t -> [Decl]+setPos st leng x y = (C.position <:> st) : uncurry setDirs (getDirs x y)+    where setDirs a b = [a <:> leng (abs x), b <:> leng (abs y)]+          getDirs x y +            | x < 0 && y < 0 = (C.right, C.bottom)+            | x < 0 && y > 0 = (C.right, C.top)+            | x > 0 && y < 0 = (C.left,  C.bottom)+            | otherwise      = (C.left,  C.top)++relPos :: (Num t, Ord t) => (t -> Expr) -> t -> t -> [Decl]+relPos = setPos C.relative++fixPos :: (Num t, Ord t) => (t -> Expr) -> t -> t -> [Decl]+fixPos = setPos C.fixed++absPos :: (Num t, Ord t) => (t -> Expr) -> t -> t -> [Decl]+absPos = setPos C.absolute+--}+-- floats+--++-- | sets @float@ property to @left@+lfloat :: [Decl]+lfloat = [fl]++-- | sets @float@ property to @right@+rfloat :: [Decl]+rfloat = [fr]++-- | sets @clear@ property to @both@+bclear :: [Decl]+bclear = [cb]++-- | sets @clear@ property to @right@+rclear :: [Decl]+rclear = [cr]++-- | sets @clear@ property to @left@+lclear :: [Decl]+lclear = [cl]++++++-- border++type BorderColor = Expr+type BorderWidth = Expr+type BorderStyle = Expr++data Dir = DAll | DLeft | DRight | DBottom | DTop++instance Show Dir where+    show a = case a of+                DAll    -> ""+                DLeft   -> "-left"+                DRight  -> "-right"+                DBottom -> "-bottom"+                DTop    -> "-top"+++top = DTop+left = DLeft+right = DRight+bottom = DBottom++-- | >sides = [left, top, right, bottom]+sides :: [Dir]+sides = [DAll]++-- | >hor = [left, right]+hor :: [Dir]+hor = [left, right]++-- | >ver = [top, bottom]+ver :: [Dir]+ver = [top, bottom]++-- | sets @border@ properties+border :: [Dir] -> BorderStyle -> BorderWidth -> BorderColor -> [Decl]+border dirs st wid col = map fromDir dirs+    where fromDir x = (ident $ "border" ++ show x) <:> spaces [wid, st, col]++-- | sets @border@ property to none and assigns @border-width@ to zero+borderNone :: [Dir] -> [Decl]+borderNone dirs = map fromDir dirs+    where fromDir x = (ident $ "border" ++ show x) <:> int 0++-- | sets @margin@ width+margin :: [Dir] -> Expr -> [Decl]+margin dirs e = map fromDirs dirs+    where fromDirs x = (ident "margin" ++ show x) <:> e++-- | sets @padding@ width+padding :: [Dir] -> Expr -> [Decl]+padding dirs e = map fromDirs dirs+    where fromDirs x = (ident "padding" ++ show x) <:> e++-- | sets @wdth@+width :: Expr -> [Decl]+width e = [C.width <:> e]++-- | sets @height@+height :: Expr -> [Decl]+height e = [C.height <:> e]+++-- background++-- | sets @background-color@ property+bkgColor :: Expr -> [Decl]+bkgColor e = [C.backgroundColor <:> e]++-- | sets color and background-color properties+brick :: Expr -> Expr -> [Decl]+brick col bkg = [C.color <:> col, C.backgroundColor <:> bkg, C.textDecoration <:> C.none]++-- | loads picture to background+pict :: String -> [Decl]+pict file = [C.backgroundImage <:> url file]+++-- text++-- | sets @color@ property to specified color+color :: Expr -> [Decl]+color x = [C.color <:> x] ++-- mouse - interaction++-- | Box model+--+-- elements groupped in box can be displayed as @block@ or as @inline-block@+data Box = InlineBlock [Decl] | Block [Decl]++-- | block box+box :: [Decl] -> Box+box = Block++-- | inline-block box+ibox :: [Decl] -> Box+ibox = InlineBlock++decls :: Box -> [Decl]+decls x = +    case x of+        InlineBlock ds -> ds ++ [C.display <:> C.inlineBlock]+        Block       ds -> ds ++ [C.display <:> C.block]+    ++---------------------------------------------------+-- translators++-- | static box+static :: Box -> Css a -> Css a+static ds = div' . (dot $ decls ds)++-- | rollover box+--+-- arguments :+--+-- * static box+--+-- * on hover box+rollOver :: Box -> Box -> Css a -> Css a+rollOver staticBox hoverBox = div' . pseudo [(ident "hover", h)] . dot s+    where s = decls staticBox+          h = decls hoverBox+++-- | mouse-interaction box+-- arguments :+--+-- * link+--+-- * visited+--+-- * hover+--+-- * active+--+-- box++onMouse :: Box -> Box -> Box -> Box -> (Css a -> Css a)+onMouse l v h a = +    div' . +    pseudo [(ident "link",    decls l),+            (ident "visited", decls v),+            (ident "hover",   decls h),+            (ident "active",  decls a)]+
+ src/SimpleCss/Tricks/Shortcuts/Html.hs view
@@ -0,0 +1,172 @@+module SimpleCss.Tricks.Shortcuts.Html +    (p, a, img, pre,+     h1, h2, h3, h4, h5, h6,+     ul, ol, aul, aol, table,+     encoding, writeBlazeCss, initHtmls)+where++import Language.Css.Syntax+import Language.Css.Build++import SimpleCss ++import qualified Text.Blaze.Renderer.String as H+import qualified Text.Blaze as H+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as HA+++-- html-elements++textTag tag = prim . tag . H.string++-- | @p@ tag +p :: String -> Css H.Html+p = textTag H.p++-- | @pre@ tag+pre :: String -> Css H.Html+pre = textTag H.pre++-- | @a@ tag+--+-- arguments+--+-- * href+--+-- * text+a :: String -> String -> Css H.Html+a href text = prim $ H.a H.! HA.href (H.stringValue href) $ H.string text++-- headers++-- | @h1@ tag +h1 :: String -> Css H.Html+h1 = textTag H.h1++-- | @h2@ tag +h2 :: String -> Css H.Html+h2 = textTag H.h2++-- | @h3@ tag +h3 :: String -> Css H.Html+h3 = textTag H.h3++-- | @h4@ tag +h4 :: String -> Css H.Html+h4 = textTag H.h4++-- | @h5@ tag +h5 :: String -> Css H.Html+h5 = textTag H.h5++-- | @h6@ tag +h6 :: String -> Css H.Html+h6 = textTag H.h6++-- | images+--+-- arguments :+--+-- * @alt@ atribute value+--+-- * @src@ atribute value+img :: String -> String -> Css H.Html+img alt src = prim $ H.img H.! HA.src (H.stringValue src) H.! HA.alt (H.stringValue alt)+++-- | @ul@ tag+ul :: [String] -> Css H.Html +ul = ls H.ul++-- | @ol@ tag+ol :: [String] -> Css H.Html+ol = ls H.ol++-- lists+ls constr = prim . constr . foldl1 (>>) . map (H.li . H.string)+++-- | @ul@ tag with links+--+-- arguments : [(href, text)]+aul :: [(String, String)] -> Css H.Html +aul = als H.ul++-- | @ol@ tag with links+--+-- arguments : [(href, text)]+aol :: [(String, String)] -> Css H.Html+aol = als H.ol+++als constr = prim . constr . foldl1 (>>) . map (H.li . setA)+    where setA (href, name) = H.a H.! HA.href (H.stringValue href) $ H.string name++++-- tables++-- | table+--+-- arguments :+--+-- * Maybe header+--+-- * [rows]+--+table :: Maybe [String] -> [[String]] -> Css H.Html+table h rs = prim $ H.table $ +    case h of+        Just x  -> tr H.th x >> trs+        Nothing -> trs+    where tr f x  = H.tr $ foldl (>>) (return ()) $ map (f . H.string) x+          trs     = foldl1 (>>) $ map (tr H.td) rs   ++++encoding :: String -> H.Html+encoding str = H.meta H.! HA.http_equiv (H.stringValue "Content-Type")+                      H.! HA.content (H.stringValue "text/html")+                      H.! HA.charset (H.stringValue str)+++-- | writes css and htmls to files+--+-- arguments :+-- +-- * css file name+--+-- * 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) >> +    (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"+++formHtml :: String -> H.Html -> H.Html -> String+formHtml cssFile hHead hBody = H.renderHtml $ H.docTypeHtml $ H.html $ +    (H.head $ linkCss cssFile >> hHead) >> (H.body hBody)+    where body' = H.body hBody+          head' = H.head $ linkCss cssFile >> hHead+    ++linkCss :: String -> H.Html+linkCss cssFile = +    H.link H.! HA.rel   (H.stringValue "stylesheet")+           H.! HA.type_ (H.stringValue "text/css") +           H.! HA.href  (H.stringValue cssFile)++-- | genereates html filenames and head's sublelements from list of titles+initHtmls :: [String] -> [(String, H.Html)]+initHtmls names = zip (map (++ ".html") names) $ map fromTitle names++fromTitle :: String -> H.Html+fromTitle title = encoding "UTF-8" >> (H.title $ H.string title)+++