packages feed

BluePrintCSS (empty) → 0.1

raw patch · 8 files changed

+404/−0 lines, 8 filesdep +basedep +blaze-htmldep +hsxsetup-changed

Dependencies added: base, blaze-html, hsx, mtl

Files

+ BluePrintCSS.cabal view
@@ -0,0 +1,45 @@+Name:                BluePrintCSS+Version:             0.1+Synopsis:            Html document layout library.+Description:         The library helps to format html documents using popular BluePrint CSS framework <http://www.blueprintcss.org/>. Currently, Blaze and HSX html generators are supported (note 'blaze' and 'hsx' flags). See repository for complex examples.+                     +License:             BSD3+License-file:        LICENSE+Author:              Sergey Mironov+Homepage:            http://git.ierton.ru/?p=BluePrint.git;a=summary+Maintainer:          Sergey Mironov <ierton@gmail.com>+Build-Type:          Simple+Cabal-Version:       >=1.6+Stability:           Experimental+Category:            Web, Text++Flag hsx+    Description: Include HSX xml generator support+    Default: False++Flag blaze+    Description: Include blaze-html generator support+    Default: False++Library++  Exposed-modules:     Text.BluePrintCSS.Base,+                       Text.BluePrintCSS.Attr,+                       Text.BluePrintCSS++  if flag(blaze) +    Exposed-modules:   Text.BluePrintCSS.Blaze+    Build-Depends:     blaze-html  ++  if flag(hsx) +    Exposed-modules:   Text.BluePrintCSS.XMLGenT+    Build-Depends:     hsx  ++  Build-Depends:       base >=4 && < 5, mtl++  cpp-options:         -DBASE4++  hs-source-dirs:      src++  Extensions:          TypeSynonymInstances,MultiParamTypeClasses,FlexibleInstances,UndecidableInstances,TypeFamilies+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010, Sergey Mironov+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 the BluePrintCSS; nor the names of its+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,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/BluePrintCSS.hs view
@@ -0,0 +1,8 @@+module Text.BluePrintCSS+    ( module Text.BluePrintCSS.Base+    , module Text.BluePrintCSS.Attr+    ) where++import Text.BluePrintCSS.Base+import Text.BluePrintCSS.Attr+
+ src/Text/BluePrintCSS/Attr.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Text.BluePrintCSS.Attr where++import Text.BluePrintCSS.Base+++data BoxStyle = Box | Error | Notice | Success+    deriving(Show)++data Attr = Decoration BoxStyle | Append Int | Prepend Int | ShowGrid | ColBorder+    deriving(Show)++type Attrs = [Attr]++toCssClass :: Attr -> String+toCssClass (Decoration Error) = "error"+toCssClass (Decoration Notice) = "notice"+toCssClass (Decoration Success) = "success"+toCssClass (Decoration Box) = "box"+toCssClass ShowGrid = "showgrid"+toCssClass (Append x) = "append-"++show(x)+toCssClass (Prepend x) = "prepend-"++show(x)+toCssClass (ColBorder) = "colborder"++margin :: Attr -> Int+margin (Decoration _) = 1+margin (ColBorder) = 1+margin (Append x) = x+margin (Prepend x) = x+margin _ = 0++instance AsCssClass Attrs where+    asCssClass = map toCssClass++instance AsMargin Attrs where+    smargin = sum . map margin++
+ src/Text/BluePrintCSS/Base.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Text.BluePrintCSS.Base (+    render,+    section,+    Layout(..),+    AsSection(..),+    AsMargin(..),+    AsCssClass(..),+    makeCssClass,+    Tag(..),+    Align(..),+    hsectionA,+    hsection,+    vsectionA,+    vsection,+    equalA,+    equal,+    greaterA,+    greater,+    floatA,+    float+    ) where ++import Control.Monad+import Control.Monad.Writer+import Data.Maybe ()+import Data.Either ()+import Data.List++-- | User can specify fixed of `greater than` width of section.+-- Width is measured in blueprint css units (see official manual)+data Layout = LEQ Int | LGE Int +    deriving (Eq,Show)++(.|.) :: Layout -> Layout -> Layout+LEQ m .|. LEQ n = LEQ (m+n)+LGE m .|. LGE n = LGE (m+n)+LEQ m .|. LGE n = LGE (m+n)+LGE n .|. LEQ m = LGE (m+n)++(.||.) :: [Layout] -> [Layout] -> [Layout]+(.||.) = zipWith (.|.)++hsum :: [Layout] -> Layout+hsum = foldr (.|.) (LEQ 0)++(./.) :: Layout -> Layout -> Layout+LEQ m ./. LEQ n = LEQ (m `max` n)+LGE m ./. LGE n = LGE (m `max` n)+LEQ m ./. LGE n = LGE (m `max` n) --undefined+LGE n ./. LEQ m = LGE (m `max` n) --undefined++vsum :: [Layout] -> Layout+vsum = foldr (./.) (LEQ 0)++lmax :: Layout -> Layout -> Layout+LGE x `lmax` LGE y = LGE (x`max`y)+LEQ x `lmax` LGE y | y<=x = LEQ x+LEQ x `lmax` LGE _ | otherwise = LEQ x --undefined+LGE y `lmax` LEQ x | y<=x = LEQ x+LGE _ `lmax` LEQ x | otherwise = LEQ x --undefined+LEQ x `lmax` LEQ y = LEQ (x`min`y) --undefined++llmax :: [Layout] -> [Layout] -> [Layout]+llmax = zipWith lmax++fits :: Layout -> Int -> Bool+(LEQ x) `fits` y = x == y+(LGE x) `fits` y = x < y++classify :: [Layout] -> ([Int],[Int])+classify = foldr classify' ([],[])+    where classify' (LEQ w) (fx, dn) = (w:fx, dn) +          classify' (LGE w) (fx, dn) = (fx, w:dn) ++(.++.) :: [Int] -> [Int] -> [Int]+(.++.) = zipWith (+)++class AsCssClass x where+    asCssClass :: x -> [String]++makeCssClass :: (AsCssClass x) => x -> Int -> Bool -> [String]+makeCssClass attrs w l =+    let cspan = ["span-" ++ show(w)] in+    let clast = if l then ["last"] else [] in+    cspan ++ (asCssClass attrs) ++ clast++split :: Int -> Int -> [Int]+split x parts +    | x < parts = (replicate x 1) ++ (replicate (parts-x) 0)+    | otherwise = +        let (quot', rem') = (x`div`parts, x`mod`parts) in+        (replicate parts quot') .++. (split rem' parts)++distribute :: Int -> [Layout] -> [Int]+distribute w attrs@(_:_) =+    let (fixed,floated) = classify attrs in+    let (sfx,sfl) = (sum fixed, sum floated) in+    let free = w - sfl - sfx in+    let float' = floated .++. split free (length floated) in+    fst $ foldr fn ([],(reverse fixed, reverse float')) attrs+    where+        fn (LEQ _) (res, (f:fx, fl)) = (f:res, (fx, fl)) +        fn (LEQ _) (_, ([], _)) = undefined+        fn (LGE _) (res, (fx, f:fl)) = (f:res, (fx, fl)) +        fn (LGE _) (_, (_, [])) = undefined+distribute _ [] = []++class AsMargin x where+    smargin :: x -> Int++data Align = HSet | VSet+    deriving(Show)++-- | Tuple represents individual section of blueprint document.+-- First argument is Layout (width constraint)+-- Second argument is a set of attributes (typically list of 'Attr')+-- Third argument is a section itself.+type Tuple a d = (Layout, a, Tag a d)++-- | Defines Html section tree from blueprint's point of view.+data Tag a d = Tag Align [Tuple a d] | Content d+    deriving(Show)++mark :: (AsMargin a, AsSection a d) => Tag a d -> (Tag a d, Layout)+mark (Tag align tagpairs) = +    let (ls, attrs, tags) = unzip3 tagpairs+        (tags', ls') = unzip $ map mark tags+        ls'' = (ls `llmax` ls') .||. (map (LEQ . smargin) attrs)+        xsum HSet = hsum ; xsum VSet = vsum+    in (Tag align (zip3 ls'' attrs tags'), xsum align ls'')++mark (Content x) = (Content x, LGE 0)++class AsSection a d where+    asSection :: a -> Int -> Bool -> [d] -> d+    asRootSection :: a -> [d] -> d++render' :: (AsMargin a, AsSection a d) => Int -> Tag a d -> [d]+render' cw (Tag HSet tagpairs) = +    let (ls, attrs, tags) = unzip3 tagpairs in+    let ws = distribute cw ls in+    execWriter $ do+        forM_ (zip4 tags attrs ws [1..]) $ \(tag, attr, w, i) -> do+            let w' = w - smargin attr+            let c = render' w' tag+            tell $ [asSection attr w' (i==(length ws)) c]++render' w (Tag VSet tagpairs) = +    execWriter $ do+        forM_ (tagpairs) $ \(_,attr,tag) -> do+            let w' = w - smargin attr+            let c = render' w' tag+            tell $ [asSection attr w' True c]++render' _ (Content content) = [content]+ +-- | The most important function. Renders structure into solid html.+-- First argument is total width of your css grid (see blueprintcss manual).+-- Typical value is 24.+-- Second argument is the document skeleton as returned by one of *section functions.+-- Use it like this (HSX html generator is assumed):+--+-- > render 24 $ vsection [ +-- >   float $ <h1> The header </h1>,+-- >   floatA [Box "Error"] $ <p>Password incorrect</p>,+-- >   hsection [ +-- >     equal 3 $ <div> Column of width 3 </div>,+-- >     float   $ <div> Column of width (max - 3) </div>+-- >   ] +-- > ]+--+render :: (AsMargin a, AsSection a d) => Int -> Tuple a d -> Either String d+render w (_,a,t) = +    let (tree, l) = mark t in+    case l `fits` w of+        True -> Right $ asRootSection a $ render' w tree+        False -> Left $ "It is impossible to fit layout " ++ show(l) ++ " into " ++ show(w) ++ " box"++section :: a -> b -> c-> (a,b,c)+section = (,,)++-- | Starts horisontally aligned sectionlist+hsection :: (Monoid a) => [Tuple a d] -> Tuple a d+hsection = hsectionA mempty++-- | Starts vertically aligned section+vsection :: (Monoid a) => [Tuple a d] -> Tuple a d+vsection = vsectionA mempty++-- | Defines html content of fixed width.+-- First argument is a width allowed for this content (in blueprintcss units, see manual).+-- Second argument - html data type+equal :: (Monoid a) => Int -> d -> Tuple a d+equal = equalA mempty++-- | Defines html content with width in range [arg1 .. max).+-- First argument is a minimal width allowed (in blueprintcss units, see manual).+-- Second argument - html data type+greater :: (Monoid a) => Int -> d -> Tuple a d+greater = greaterA mempty++-- | Defines html content with any width (same as 'greater' with arg1 = 0) +float :: (Monoid a) => d -> Tuple a d+float = floatA mempty++-- | Attributed version of hsection.+-- First argument is a attribute list which allows to tweak `class` of html tag.+-- Standard blueprint library contains a set of pre-defined classes like+-- `error`, `notify`, `box`, `append-`, `prepend-`.+-- Some of them, like `pull-` and `push-` are not supported.+-- See 'Attr' for details.+hsectionA :: a -> [Tuple a d] -> Tuple a d+hsectionA attrs = section (LGE 0) attrs . Tag HSet ++-- | Attributed version of 'vsection'+vsectionA :: a -> [Tuple a d] -> Tuple a d+vsectionA attrs = section (LGE 0) attrs . Tag VSet ++-- | Attributed version of 'equal'+equalA :: a -> Int -> d -> Tuple a d+equalA attrs x = section (LEQ x) attrs . Content++-- | Attributed version of 'greater'+greaterA :: a -> Int -> d -> Tuple a d+greaterA attrs x = section (LGE x) attrs . Content++-- | Attributed version of 'float'+floatA :: a -> d -> Tuple a d+floatA attrs = greaterA attrs 0+
+ src/Text/BluePrintCSS/Blaze.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.BluePrintCSS.Blaze where ++import Control.Monad+import Text.Blaze+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A+import Text.BluePrintCSS++instance (AsCssClass x) => AsSection x (Html a) where+    asSection attrs w last chld =+        H.div ! A.class_ (stringValue $ unwords $ makeCssClass attrs w last) $ do+            sequence chld++    asRootSection attrs chld =+        H.div ! A.class_ (stringValue $ unwords ("container":asCssClass attrs)) $ do+            sequence chld+
+ src/Text/BluePrintCSS/XMLGenT.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -F -pgmF trhsx #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Text.BluePrintCSS.XMLGenT where ++import qualified Text.BluePrintCSS as BP+import HSX.XMLGenerator++instance (+    XMLGen m+    ,a ~ (XML m)+    ,EmbedAsChild m a+    ,EmbedAsAttr m (Attr [Char] String)+    ,BP.AsCssClass x+    ) => BP.AsSection x (XMLGenT m a) +    where+    asSection attrs w last chld =+        <div class=(unwords $ BP.makeCssClass attrs w last)><% chld %></div>++    asRootSection attrs chld =+        <div class=(unwords $ ("container":BP.asCssClass attrs))><% chld %></div>+