diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 diff --git a/simple-css.cabal b/simple-css.cabal new file mode 100644 --- /dev/null +++ b/simple-css.cabal @@ -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: +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: + + + + diff --git a/src/SimpleCss.hs b/src/SimpleCss.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss.hs @@ -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) + + diff --git a/src/SimpleCss/Tricks.hs b/src/SimpleCss/Tricks.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss/Tricks.hs @@ -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 + + diff --git a/src/SimpleCss/Tricks/Images.hs b/src/SimpleCss/Tricks/Images.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss/Tricks/Images.hs @@ -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]) + diff --git a/src/SimpleCss/Tricks/Layouts.hs b/src/SimpleCss/Tricks/Layouts.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss/Tricks/Layouts.hs @@ -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 +-- +-- 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 + diff --git a/src/SimpleCss/Tricks/Menus.hs b/src/SimpleCss/Tricks/Menus.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss/Tricks/Menus.hs @@ -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 diff --git a/src/SimpleCss/Tricks/Shortcuts/Css.hs b/src/SimpleCss/Tricks/Shortcuts/Css.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss/Tricks/Shortcuts/Css.hs @@ -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)] + diff --git a/src/SimpleCss/Tricks/Shortcuts/Html.hs b/src/SimpleCss/Tricks/Shortcuts/Html.hs new file mode 100644 --- /dev/null +++ b/src/SimpleCss/Tricks/Shortcuts/Html.hs @@ -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) + + +