packages feed

yuiGrid (empty) → 0.1

raw patch · 21 files changed

+1291/−0 lines, 21 filesdep +basesetup-changedbinary-added

Dependencies added: base

Files

+ AUTHORS view
@@ -0,0 +1,3 @@+Tom Nielsen (tanielsen@gmail.com): Initital design and development.+Sergio Urinovsky (sergio.urinovsky@gmail.com): Design and lead developer.+
+ Example/GridExample.hs view
@@ -0,0 +1,102 @@+module Main where++import Text.CxML+import Text.YuiGrid+import Network.HTTP.RedHandler+import Control.Monad.Reader (ask)+++-----------------------------------------------+-- Responses with grids+-----------------------------------------------++type GridResp = HandlerRsp [GridElement ()]++gridRespToRsp :: GridResp -> BasicRsp+gridRespToRsp = basicRspWith (showNonCxmlStrict "Grid Example" . gridPage)++-----------------------------------------------+-- Utilities for Handlers with Grid responses+-----------------------------------------------++-- | add contextual grid elements to the dynamic response+inGridWithElems :: Monad m => [GridElement RequestContext] -> RqHandlerT m GridResp -> RqHandlerT m GridResp+inGridWithElems ges handl = do ges' <- fmap (runBoxes ges) ask+                               fmap (fmap (++ ges')) handl++-- | turn a contextual html into a grid response handler+okCxML :: Monad m => CxML RequestContext -> RqHandlerT m GridResp+okCxML cx = fmap ( return . (:[]) . boxInMain . runCxML cx) ask+++-----------------------------------------------+-- Main daemon and port+-----------------------------------------------+main :: IO ()+main = runHttpServer 8080 mainHandlers++-----------------------------------------------+-- Routes and handlers+-----------------------------------------------+mainHandlers :: [IORqHandler BasicRsp]+mainHandlers = [staticFilesHandler, appHandlers]++staticFilesHandler = under "pictures" $ mapDir "./images/"++appHandlers = modResp gridRespToRsp $ appCtx $ anyOf [greetHandler, inputFormHandler]+++inputFormHandler :: IORqHandler GridResp+inputFormHandler = okCxML inputForm++greetHandler :: IORqHandler GridResp+greetHandler =  ifPost $ +                 withPostField "name" (\n -> if null n +                                               then notMe +                                               else okCxML (greet n)+                                       )+++greet :: String -> CxML a+greet n = p /- [t $ "Hello " ++ n ++ "!"]++inputForm :: CxML a+inputForm = form!("method","post")+                /- [+                    p /- [t "My name is ", textfield "name"],+                    button!("name","action")!("value","submit") /- [t "Submit"]+                   ]++++-----------------------------------------------+-- Application GRID context+-----------------------------------------------+appCtx :: Monad m => RqHandlerT m GridResp -> RqHandlerT m GridResp+appCtx h = do+              inGridWithElems [+                   boxInFooter (t "Footer goes here."),+                   boxInHeader (h1logo "Header image goes in the URL" "/pictures/header.gif"),+                   smallMarginBottomCSS $ nearLeft $ setColumnsVote 2 $ nearBottom $ boxInHeader (loginControl "Guest"),+                   smallMarginBottomCSS $ nearRight $ setColumnsVote 2 $ nearBottom $ boxInHeader searchForm,+                   boxInLeftSidebar (vertNav [("Home", "/"),+                                                  ("About", "/about"),+                                                  ("Contact", "/contact")])+                  ] $ h+++-----------------------------------------------+-- More contextual htmls used in the example+-----------------------------------------------+searchForm :: CxML a+searchForm+           = form!("method","post")!("action","/search.html")+                /- [+                    textfield "search", +                    button!("name","action")!("value","submit") /- [t "Search"]+                   ]+++loginControl ::String -> CxML a+loginControl userName = t ("User: " ++ userName)+
+ Example/Makefile view
@@ -0,0 +1,8 @@+.PHONY: application clean++application:+	ghc -o GridExample --make GridExample.hs++clean:+	-rm GridExample+	-rm *.o *.hi *~
+ Example/README view
@@ -0,0 +1,8 @@+BUILD:+In order to build the example you need to setup also the "redHandlers" pkg.+Then just run "make" to make the example.++RUN:+The example is a standalone web application listening on port 8080.+ - Run the application "main"+ - Open a browser and try the URL: http://localhost:8080/
+ Example/images/header.gif view

binary file changed (absent → 26128 bytes)

+ LICENSE view
@@ -0,0 +1,25 @@+The MIT License++Copyright (c) 2009 RedNucleus LTD++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+
+ Text/CxML.hs view
@@ -0,0 +1,21 @@+module Text.CxML +    (+     h1logo, vertNav, --module Text.CxML.NavList,+     (^#), (^.), t, (!), hidden, textfield, afile, --Text.CxML.HTML,+     (^%), (^^.), --module Text.CxML.CSS,+     --module Text.CxML.JS,+     body, div, h1, tr, td, a, br, span, font, p, form, button, table, tag, title, h2, h3, h4, image, --module Text.CxML.Tags,+     showNonCxmlStrict,  --module Text.CxML.Output,+     CssInlineDecl, CxML, StyleDecl(..), (/-), concatCxML, runCxML, NonCxML, (+++), noElem, withCtx, modCx --module Text.CxML.Types+    ) where++import Prelude hiding (div, span)++import Text.CxML.Types+import Text.CxML.NavList+import Text.CxML.Tags+import Text.CxML.Output+import Text.CxML.HTML+import Text.CxML.CSS+import Text.CxML.JS+
+ Text/CxML/CSS.hs view
@@ -0,0 +1,32 @@+module Text.CxML.CSS where+-- utility functions for manipulating CSS part++import Text.CxML.Types+import Text.CxML.Tags+import Text.CxML.HTML++-- change a list of CSS declarations to prepend a selector+underSelector :: String -> [StyleDecl] -> [StyleDecl]+underSelector par rls = map (underSelector' par) rls++underSelector' par (CSSRule sel ats) = CSSRule (map prepend sel) ats+    where prepend s = par++" "++s+                      +underSelector' par sd@(_) = sd++(*>) = underSelector++-- | set style +infixl 8 ^%++(^%) :: CxML a->[StyleDecl]-> CxML a+tag ^% sty = CxML (htm tag, titleParts tag, css tag ++ sty, js tag)++-- | create HTML to link to a CSS file+csslink url = link!("type","text/css")!("rel","stylesheet")^>url+++infixl 8 ^^.+(^^.) :: CxML a -> CssInlineDecl -> CxML a+tag^^.(rlsName,rlsBody) = tag^.rlsName ^%[CSSRule ['.':rlsName] rlsBody ]+
+ Text/CxML/HTML.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Text.CxML.HTML where++import Text.CxML.Types+import Text.CxML.Tags(input)++-- | escape HTML++--newtype HtmlSafeString = HtSfString String -- this is a type safe way to prevent XSS. We may do that in the future+-- see http://blog.moertel.com/articles/2006/10/18/a-type-based-solution-to-the-strings-problem++hText = HText . escapeBrackets -- poor man's solution to the "strings problem" (see link above)++escapeBrackets :: String -> String+escapeBrackets [] = []+escapeBrackets ('<':t) = "&lt;"++escapeBrackets t+escapeBrackets ('>':t) = "&gt;"++escapeBrackets t+escapeBrackets ('&':t) = "&amp;"++escapeBrackets t+escapeBrackets ('\'':t) = "&apos;"++escapeBrackets t+escapeBrackets ('"':t) = "&qout;"++escapeBrackets t+escapeBrackets ('(':'C':')':t) = "&copy;"++escapeBrackets t --copyright+escapeBrackets (h:t) = h:(escapeBrackets t)++-- | create a text node. Automatically escape HTML to protect against XSS+t ::  String-> CxML a+t str = CxML (\_->[hText str],[],[],[])++-- modify HTML part of CxML - used in navList?+modHElems :: (HElem->HElem)->CxML a->CxML a+modHElems f (CxML (h,ts,c,j)) =  CxML (\ctx->map f $ h ctx, ts, c, j)+++class CxMLChild a b where+    (//) :: CxML a -> b -> CxML a++instance CxMLChild a (CxML a)where+    p//c= withChildren p [c]++instance CxMLChild a [CxML a]where+    p//c= withChildren p c++instance CxMLChild a [Char]where+    p//c= withChildren p [t c]++instance CxMLChild a [[Char]] where+    p//c= withChildren p $ map t c++infixl 5 //+++++-- | create an operator to set an attribute of HTML elements+setAttrOp ::  String -> (CxML a) -> String -> (CxML a)+setAttrOp at= \tag-> \val-> +              CxML (\ctx-> map (add_attr at val) $ htm tag ctx, titleParts tag, css tag,js tag )++-- | helper function for setAttrOp+add_attr :: String->String->HElem->HElem+add_attr _ _ s@(HText str)= s+add_attr nm vl (HTag tn ats chs) = HTag tn (add_attr' nm vl ats) chs+               where+                 add_attr' nm vl [] = [(nm,vl)]+                 add_attr' nm vl ((nm',vl'):ats) +                          = if (nm==nm') +                              then (nm,vl' ++ " " ++ vl):ats+                              else (nm',vl'): add_attr' nm vl ats+--FIXME: a Map could be used for the attributes, although there should be just a few per tag+++infixl 8 ^#+(^#)=setAttrOp "id"++infixl 8 ^.+(^.)=setAttrOp "class"++infixl 7 ^>+(^>)=setAttrOp "href"+++{-+maybe one day I would like ^> to set href for <a> but src for <img>+(^>) = \tag-> \val-> +       CxML (\ctx-> map (add_attr at val) $ (htm tag) ctx, css tag,js tag )+       where tagAtAssoc = [("img", "src"),+                          ("a", "href")++]-}++-- | set any attribute of HTML element+infixl 8 !+(!) :: (CxML a)->(String, String)->(CxML a)+tag ! (at,vl)  = CxML (\ctx-> map (add_attr at vl) $ htm tag ctx, titleParts tag, css tag, js tag)+++--------------------------------------------------+-----Modified from module Text.XHtml.Extras  -----+--------------------------------------------------++{-widget :: String -> String -> [HtmlAttr] -> Html+widget w n markupAttrs = input ! ([thetype w,name n,identifier n] ++ markupAttrs)++checkbox :: String -> String -> Html+hidden   :: String -> String -> Html+radio    :: String -> String -> Html+reset    :: String -> String -> Html+submit   :: String -> String -> Html+password :: String           -> Html+textfield :: String          -> Html+afile    :: String           -> Html+clickmap :: String           -> Html++checkbox n v = widget "checkbox" n [value v]+hidden   n v = widget "hidden"   n [value v]+radio    n v = widget "radio"    n [value v]+reset    n v = widget "reset"    n [value v]+submit   n v = widget "submit"   n [value v]+password n   = widget "password" n []+textfield n  = widget "text"     n []+afile    n   = widget "file"     n []+clickmap n   = widget "image"    n []+-}++widget :: String -> String -> [(String,String)] -> CxML a+widget w n markupAttrs = foldl (!) input (("type",w):("name",n):("id",n):markupAttrs)++textfield n = widget "text" n []+hidden n v = widget "hidden" n [("value",v)]+afile n = widget "file" n []
+ Text/CxML/JS.hs view
@@ -0,0 +1,15 @@+module Text.CxML.JS where++import Text.CxML.Types+import Text.CxML.Tags+import Text.CxML.HTML+++-- link to JavaScript file+jslink url = script!("type","text/javascript")!("src",url)++--  add JavaScript+(^:) :: CxML a->[JSDecl]-> CxML a+tag ^: jsd = CxML (htm tag, titleParts tag, css tag, js tag ++ jsd)++
+ Text/CxML/NavList.hs view
@@ -0,0 +1,73 @@+module Text.CxML.NavList where++import Text.CxML.Types+import Text.CxML.Tags+import Text.CxML.HTML+import Text.CxML.CSS++-- this should really be renamed CxML.Components++-- this module defines a navigation list component which can be used for tabs, left-hand vertical menu or breadcrumbs. +-- see " a list apart" on taming lists but I don't like their breadcrumbs solution with nested markup.++data NavListStyle = Tabs | Vertical | Breadcrumbs | HoverCols String String | NoUnderline | LinesBetween | AnyCSS StyleDecl+                  | TextCol String  | CurrentLinkCSS [(String, String)] | CurrentItemCSS [(String, String)]++--navList ::[NavListStyle] -> String -> [(String, String)]  -> CxML a+navList styls tid (item:items) = ul^#tid^%(('#':tid) *> (concatMap navStyles styls))/- ((litemf item):(map litem items))+    where litem (txt,targ) = li /- [a^>targ /- [modHElems processText $ t txt]]+          litemf (txt,targ) = li^."first" /- [a^>targ /- [t txt]]+          navStyles Tabs = []+          navStyles Vertical = [CSSRule ["li a"] [("padding","4px"), ("font-size", "116%")]]+          navStyles (CurrentLinkCSS sty) = [CSSRule ["li.current a"] sty]+          navStyles (CurrentItemCSS sty) = [CSSRule ["li a"] sty]+          navStyles (TextCol cl) = [CSSRule ["li a"] [("color",cl)]]+          navStyles (HoverCols tx bg) = [CSSRule ["li:hover"] [("background-color",bg)],+                                         CSSRule ["li:hover a"] [("color",tx)]]+          navStyles NoUnderline = [CSSRule ["li a"] [("text-decoration","none")]]+          navStyles LinesBetween = [CSSRule ["li"] [("border-top","1px solid #bbbbbb")],+                                    CSSRule ["li.first"] [("border-top","none")]+                                   ]+          navStyles Breadcrumbs = [CSSRule ["li","ul"] [("display","inline"), ("margin", "0"),("padding", "0")]]+          prependChar Breadcrumbs = "&#187; "+          prependChar _ = ""+          processText (HText t)= HText ((concatMap prependChar styls )++t)+          processText h = h++vertNav = navList [Vertical, NoUnderline, LinesBetween, TextCol "#000", HoverCols "#f33" "#ccc"] "vertNav"++--http://www.sixshootermedia.com/blog/semantic-h1-logo-link/+h1logo txt imgpath = h1^#"h1logo"^%rls /- [t txt] + where rls = [CSSRule ["#h1logo"] [("text-indent","-9999px"),+                                   ("background", "url("++imgpath++") no-repeat;"),+                                   ("width", "100%"),("height","60px")+                                  ]]+++formTo :: String -> [CxML a] -> CxML a+formTo actionUrl chs = +    form!("method","post")!("action",actionUrl)+             /- chs++submitBtn lbl = button!("name","action")!("value","submit") /- [t lbl]++++++{- from formerly RequestCtx.hs -}++--yuiMenu  = div^."yuimenu" // div^."bd" // [ul^."first-of-type" // "hello world"]++--div^."yuimenu" // div^."bd" // ul^."first-of-type" // "hello world" -- yawn++-- http://www.alistapart.com/articles/prettyaccessibleforms+formSection nm contents = if null nm +                             then fieldset /- [ol /- contents]+                             else fieldset /- [legend /- [t nm],+                                               ol /- contents]++--setValFromCtx :: (a -> String) -> CxML a -> CxML a+--setValFromCtx stLam (CxML (h,c,j))= CxML (\ctx-> map (add_attr "value" (stLam ctx)) $ h ctx, c,j )++
+ Text/CxML/Output.hs view
@@ -0,0 +1,93 @@+module Text.CxML.Output --miscellaneous functions for outputting or simplifying contextual markup+  (showNonCxmlStrict)+where++import Data.List (intercalate, nub)++import Text.CxML.Types+import Text.CxML.Tags+import Text.CxML.HTML+import Text.CxML.CSS (csslink)++--from module Text.XHtml.Strict+strictDocType = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\""+          ++ " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"+--FIXME: check doc type. The short way to specify tags without children is not+--being correctly parsed by firefox, so probably the doc type is wrong.+++-- | convert static parts of the document to dynamic HTML+fullInlineDoc :: String -> CxML a -> CxML a+fullInlineDoc titl bod+           = (tag "html")!("xmlns","http://www.w3.org/1999/xhtml") /-+                    [+                     header /- (theTitle : staticCSSLinks ++ [inlineParts]),+                     body /- [htmlPart bod, inlineJS $ js bod ]+                    ]+              where+                theTitle = title /- [t titl]+                css' = css bod+                staticCSSLinks = map csslink $ nub $ [url | CSSLink url <- css']+                cssRls = nub $ [(sel,declBlock) | CSSRule sel declBlock <- css']+                -- FIXME: expensive, since compares the full rule. For a small improvement, consider using:+                -- nubBy :: (a -> a -> Bool) -> [a] -> [a]+                inlineParts = inlineCSS cssRls+--FIXME: list of CSS is traversed twice+--FIXME: still lacks JS++-- | convert CSS Rule into a HTML style tag+inlineCSS :: [([String], [(String,String)])]-> CxML a+inlineCSS [] = noElem+inlineCSS cssRls = style!("type", "text/css")!("media","screen") /- [t $ concatMap showRule cssRls]+                   where+                     showRule (sel,declBlock) = concat [ intercalate "," sel, " {",+                                                         concatMap (\(at,vl)->at++":"++vl++";") declBlock,+                                                         "}\n" ]+-- | convert JavaScript into a HTML script tag+inlineJS :: [JSDecl]-> CxML a+inlineJS [] = noElem+inlineJS js = script!("type","text/javascript")/- [t $ show js]++instance Show JSDecl where+  show (OnLoad s) = s+++-- | Pretty printing   CxML ()+showNonCx :: CxML () -> String+showNonCx (CxML (h,ts,c,j)) = concatMap (showNice' 0) $ h ()++-- |  show HTML starting with no indentation+showNice = showNice' 0++-- |  show HTML with indentation, one space per level+showNice' :: Int -> HElem -> String+showNice' i (HText str) = concat [spaces i,str, "\n" ]+showNice' i (HTag nm@"div" ats chs) = concat [spaces i, "<", nm,+                                        concatMap (\(an, av)->" "++an++"=\""++av++"\"") ats, ">\n",+                                        concatMap (showNice' (i+1)) chs, spaces i, "</", nm, ">\n"]+--FIXME: Not just for divs. There are more tags that can not be rendered short even if there are no children++showNice' i (HTag nm [] []) = concat [spaces i, "<", nm, " />\n" ]+showNice' i (HTag nm ats chs) = concat [spaces i, "<", nm,+                                        concatMap (\(an, av)->" "++an++"=\""++av++"\"") ats, ">\n",+                                        concatMap (showNice' (i+1)) chs, spaces i, "</", nm, ">\n"]+spaces i = replicate i ' '+++showNonCxmlStrict :: String -> CxML () -> String+showNonCxmlStrict titl = (strictDocType ++) . showNonCx . fullInlineDoc titl+++{-+-- debugging+showDoc cxml ctx = concat [strictDocType, concatMap show $ (htm cxml) ctx]+printFullDoc doc ctx = putStr $ showDoc (fullInlineDoc "TheTitle" doc) ctx++instance Show HElem where+  show h =  showNice h++showJS:: [JSDecl]->String+showJS jss = concat ["Event.observe(window, 'load', function() {",+                     concatMap show jss,+                     "});"]+-}
+ Text/CxML/Tags.hs view
@@ -0,0 +1,97 @@+module Text.CxML.Tags where++import Text.CxML.Types++-- |  combinator to create tags+tag ::  String->CxML a+tag nm  = CxML (\_-> [HTag nm [] []],+                 [] ,+                 [] ,+                 [])++-- used to be with no children but don't distinguish now+itag ::  String-> CxML a+itag = tag ++---------------------------------------------------------+-----Modified from module Text.XHtml.Strict.Elements-----+---------------------------------------------------------++abbr                =  tag "abbr"+acronym             =  tag "acronym"+address             =  tag "address"+a              =  tag "a"+area                = itag "area"+bdo                 =  tag "bdo"+big                 =  tag "big"+blockquote          =  tag "blockquote"+body                =  tag "body"+bold                =  tag "b"+button              =  tag "button"+br                  = itag "br"+caption             =  tag "caption"+cite                =  tag "cite"+col                 =  tag "col"+colgroup            =  tag "colgroup"+dd                =  tag "dd"+dfn              =  tag "dfn"+del                 =  tag "del"+dl               =  tag "dl"+dt               =  tag "dt"+em           =  tag "em"+fieldset            =  tag "fieldset"+form                =  tag "form"+h1                  =  tag "h1"+h2                  =  tag "h2"+h3                  =  tag "h3"+h4                  =  tag "h4"+h5                  =  tag "h5"+h6                  =  tag "h6"+header              =  tag "head"+hr                  = itag "hr"+image               = itag "img"+input               = itag "input"+ins                 =  tag "ins"+italics             =  tag "i"+keyboard            =  tag "kbd"+label               =  tag "label"+legend              =  tag "legend"+li                  =  tag "li"+meta                = itag "meta"+noscript            =  tag "noscript"+object              =  tag "object"+ol               =  tag "ol"+optgroup            =  tag "optgroup"+option              =  tag "option"+p           =  tag "p"+param               = itag "param"+pre                 =  tag "pre"+quote               =  tag "q"+sample              =  tag "samp"+script              =  tag "script"+dropdown            =  tag "select"+small               =  tag "small"+strong              =  tag "strong"+style               =  tag "style"+sub                 =  tag "sub"+sup                 =  tag "sup"+table               =  tag "table"+tbody               =  tag "tbody"+td                  =  tag "td"+textarea            =  tag "textarea"+tfoot               =  tag "tfoot"+th                  =  tag "th"+thead               =  tag "thead"+base             = itag "base"+code             =  tag "code"+div              =  tag "div"+html             =  tag "html"+link             =  tag "link"+themap              =  tag "map"+span             =  tag "span"+title            =  tag "title"+tr                  =  tag "tr"+tt                  =  tag "tt"+ul               =  tag "ul"+var            =  tag "var"+font                =  tag "font"
+ Text/CxML/Types.hs view
@@ -0,0 +1,80 @@+module Text.CxML.Types where++-- | contextual markup - generates HTML as a function of a context of type a. +--   also keep track of static CSS and  JavaScript+newtype CxML a = CxML (a->[HElem],[String],[StyleDecl],[JSDecl])++-- non-contextual equivalent useful mainly for making type checker happy occasionally+type NonCxML = CxML ()++-- | HTML elements+data HElem = HTag {- tagName -} String [Attr] [HElem] +           | HText String++type Attr = (String,String)++-- | how to declare CSS &  JavaScript+type CssInlineDecl = (String {-id without prefix . -}, [(String,String)] {- css rules -})++data StyleDecl = CSSRule [String] [(String,String)]+               | CSSLink String -- specify a dependency on a CSS file (mostly hosted by Yahoo or us)++data JSDecl = OnLoad String+            | JSLink String  -- specify a dependency on a JS file (mostly hosted by Yahoo or us)++-- use a context to turn contextual into non-contextual markup+runCxML :: CxML a -> a -> NonCxML+runCxML (CxML (h,ts,c,j)) cx =  CxML (\_->h cx,ts, c, j)++-- concatenate two bits of contextual marker+infixr 2 +++  -- combining Html+(+++) :: CxML a -> CxML a -> CxML a+(CxML (h1,ts1,c1,j1)) +++ (CxML (h2,ts2,c2,j2)) =  CxML (\ctx->((h1 ctx)++(h2 ctx)), ts1++ts2, c1++c2, j1++j2)++concatCxML :: [CxML a] -> CxML a+concatCxML= foldr (+++) noElem++-- | empty tag+noElem = CxML (\_->[],[],[],[])++-- | set the HTML children +withChildren :: CxML a-> [CxML a]-> CxML a+withChildren prnt chs = CxML (\ctx->addch ((htm prnt) ctx) $ concatMap (($ctx) . htm) chs, +                (titleParts prnt),+                (css prnt)++(concatMap css chs),+                (js prnt)++(concatMap js chs))+    where addch ((HTag tn ats oldch):_) newch = [HTag tn ats (oldch++newch)]++withCtx :: (a->CxML a)->CxML a+withCtx cxLam = CxML (\ctx->(htm (cxLam ctx) ctx), [], [], [])+++-- the non-overloaded withChildren operator+infixl 5 /-++(/-) :: CxML b -> [CxML b] -> CxML b+(/-) p c = withChildren p c++-- | access title parts+titleParts (CxML (_,ts,_,_))= ts++-- | access JavaScript ( static) part+js (CxML (_,_,_,j))= j++-- | access CSS ( static ) part+css (CxML (_,_,c,_))= c++-- | access html (dynamic) part+htm (CxML (h,_,_,_))= h++htmlPart cxml  = CxML (\ctx->(htm cxml) ctx,[],[],[])++modCx :: (b -> a) -> CxML a -> CxML b+modCx f (CxML (h,ts,c,j)) = CxML (h . f, ts, c, j)++modTitleParts :: ([String] -> [String]) -> CxML a -> CxML a+modTitleParts f (CxML (h,ts,c,j)) = CxML (h, f ts, c, j)++setTitle, addTitle :: String -> CxML a -> CxML a+setTitle t = modTitleParts (\_ -> [t])+addTitle t = modTitleParts (\ts -> ts ++ [t])
+ Text/YuiGrid.hs view
@@ -0,0 +1,39 @@+module Text.YuiGrid+    (+     HasLayoutHints, modLayoutHints,+     GridElement, GridNode(..),+     gridPage, fromGridNode, runBox, runBoxes,+     setInFstSibling, resetInFstSibling,+     addCss, resetCss, smallMarginBottomCSS, giveBorderCSS,+     inMain, inHeader, inFooter, inLeftSidebar, inRightSidebar,+     nearTop, nearBottom, weight,+     setColumns, setColumnsVote, resetColumns, resetColumnsVote,+     clearSides, nearLeft, nearRight, horizWeight,+     toBox, fromBox, toContainer, fromContainer,+     boxInMain, boxInHeader, boxInFooter, boxInLeftSidebar, boxInRightSidebar,+     applyLayouts,+    )+where++import Text.CxML (CxML, concatCxML, runCxML, showNonCxmlStrict)+import Text.YuiGrid.LayoutHints+import Text.YuiGrid.Grid+import Text.YuiGrid.YGrid+import Text.YuiGrid.YGridCxML++type GridElement a = GridNode (CxML a)++gridPage :: [GridElement a] -> CxML a+gridPage bxs = pageToCxML (yGridPage YPW_950px bxs)++fromGridNode :: GridElement a -> CxML a+fromGridNode (Box cxml _) = cxml+fromGridNode (Container cxmls _) = concatCxML $ map fromGridNode cxmls++runBox :: GridElement a -> a -> GridElement ()+runBox (Box cxml lhs) cx = Box (runCxML cxml cx) lhs+runBox (Container gns lhs) cx = Container (runBoxes gns cx) lhs++runBoxes :: [GridElement a] -> a -> [GridElement ()]+runBoxes ges req = map (`runBox` req) ges+
+ Text/YuiGrid/Grid.hs view
@@ -0,0 +1,234 @@+module Text.YuiGrid.Grid where++import Data.Maybe (fromJust, fromMaybe, catMaybes)+import Data.List (partition, maximumBy, sortBy)+import Control.Monad (mplus)+import Data.Ord (comparing)+import Text.YuiGrid.LayoutHints++data GridNode a = Box a LayoutHints+                  | Container [GridNode a] LayoutHints++instance HasLayoutHints (GridNode a) where+  --modLayoutHints :: (LayoutHints -> LayoutHints) -> GridNode a -> GridNode a+  modLayoutHints f (Box x lhs) = Box x (f lhs)+  modLayoutHints f (Container gns lhs) = Container gns (f lhs)++instance Functor GridNode where+  fmap f (Box x lhs) = Box (f x) lhs+  fmap f (Container gns lhs) = Container (map (fmap f) gns) lhs++-- other hints that might be implemented in the future+-- | ClearLeft | ClearRight | MinHeight Int | MaxHeight Int | MinWidth Int | MaxWidth Int+layoutHints :: GridNode a -> LayoutHints+layoutHints (Box _ lhs) = lhs+layoutHints (Container _ lhs) = lhs++addChildren :: GridNode a -> [GridNode a] -> GridNode a+addChildren gn [] = gn+addChildren (Container gns lhs) gns' = Container (gns ++gns') lhs+addChildren (Box x lhs) gns' = Container (toBox x : gns') lhs++-----------------------------+-- in first sibling ---------+-----------------------------+moveSiblings :: [GridNode a] -> [GridNode a]+moveSiblings [] = []+moveSiblings (gn:gns) = moveSiblings' (resetInFstSibling gn) gns++moveSiblings' :: GridNode a -> [GridNode a] -> [GridNode a]+moveSiblings' gn gns = addChildren gn (map resetInFstSibling toBeMovedGns) : notToBeMovedGns+                       where+                         (toBeMovedGns, notToBeMovedGns) = partition (inFstSibling . layoutHints) gns++-----------------------------+-- page area calculation ----+-----------------------------++gridNodesByPageArea :: [GridNode a] -> (+                                        [GridNode a], -- inMain nodes+                                        [GridNode a], -- inHeader nodes+                                        [GridNode a], -- inFooter nodes+                                        [GridNode a], -- inLeftSidebar nodes+                                        [GridNode a]  -- inRightSidebar nodes+                                       )+gridNodesByPageArea gns = (+                           lookupGridNodes InMain,+                           lookupGridNodes InHeader,+                           lookupGridNodes InFooter,+                           lookupGridNodes InLeftSidebar,+                           lookupGridNodes InRightSidebar+                          )+                         where+                            --lookupGridNodes :: PageAreaHint -> [GridNode a]+                            lookupGridNodes hint = fromMaybe [] (lookup hint classifiedGridNodes)+                            --classifiedGridNodes :: [(PageAreaHint,[GridNode a])]+                            classifiedGridNodes = partitionByEq pageArea gns++pageArea :: GridNode a -> PageAreaHint+pageArea = (fromMaybe InMain) . pageAreaHint'++pageAreaHint' :: GridNode a -> Maybe PageAreaHint+pageAreaHint' (Box _ lhs) = pageAreaHint lhs+pageAreaHint' (Container gns lhs) = pageAreaHint lhs `mplus` (occurresMost . catMaybes . map pageAreaHint') gns+++-----------------------------------+-- vertical layout calculation ----+-----------------------------------++-- must be applied to all containers, not just top level containers. It is not recursive.+gridNodesVerticalPartitions :: [GridNode a] -> [[GridNode a]]+gridNodesVerticalPartitions = map snd . sortByFst . partitionByEq (verticalHint . layoutHints) . moveSiblings++------------------------------------------+-- columns and clearsides calculation ----+------------------------------------------+splitClearSides :: [[GridNode a]] -> [[GridNode a]]+splitClearSides = splitTruesAlone ((==ClearSides) . horizontalHint . layoutHints)++splitTruesAlone :: (a->Bool) -> [[a]] -> [[a]]+splitTruesAlone f = concat . map (splitTruesAlone' f)++{-+[[top], [bot]]++[[[topCs1],[topCs2],[topothers]], [[botCs1],[botCs2],[botothers]] ]+[[topCs1],[topCs2],[topothers], [botCs1],[botCs2],[botothers] ]+                          +-}++splitTruesAlone' :: (a->Bool) -> [a] -> [[a]]+splitTruesAlone' f gns = case withFalse of+                           [] -> withTrueLists+                           _  -> withTrueLists ++ [withFalse]+                         where+                           (withTrue, withFalse) = partition f gns+                           withTrueLists = map (:[]) withTrue++gridNodesByColumns :: Maybe Int -> [GridNode a] -> [[GridNode a]]+gridNodesByColumns colSpec gns +                    = if cols == 1 +                        then [gns] -- dont care about horizontal layouts since all of them go in 1 column+                        else (balancedGroups cols . concat . gridNodesHorizontalPartitions) gns+                      where +                        cols = columns colSpec gns++gridNodesHorizontalPartitions :: [GridNode a] -> [[GridNode a]]+gridNodesHorizontalPartitions = map snd . sortByFst . partitionByEq (horizontalHint . layoutHints)+++columnsQtyOpts = [1,2,3,4]+defaultColumnQty = 1++-- select the number of columns that will be used for a subset of the children of a container+-- The first argument, is the container specification of columns+-- the second argument is a subset of the children of the container to layout+columns :: Maybe Int -> [GridNode a] -> Int+columns colSpec gns = fromMaybe (columnsQtyElection gns) colSpec++-- uses valid votes from children to select from columnsQtyOpts or the default if there are no valid votes+columnsQtyElection :: [GridNode a] -> Int+columnsQtyElection = selectColumnQtyOption . catMaybes . map (columnsQtyVote . layoutHints)++selectColumnQtyOption :: [Int] -> Int+selectColumnQtyOption [] = defaultColumnQty+selectColumnQtyOption votes = (head . sortOptionsByVotes columnsQtyOpts) votes++sortOptionsByVotes :: [Int] -> [Int] -> [Int]+sortOptionsByVotes opts votes+                       = sortBy (comparing (distance votes)) opts+                         where+                            distance :: [Int] -> Int -> Int+                            distance vs opt = sum $ map (sqr . (opt-) ) vs+                            sqr x = x*x+++--------------------------------------+------ More GridNode combinators -----+--------------------------------------++boxInMain, boxInHeader, boxInFooter, boxInLeftSidebar, boxInRightSidebar :: a -> GridNode a+boxInMain = inMain . toBox+boxInHeader = inHeader . toBox+boxInFooter = inFooter . toBox+boxInLeftSidebar = inLeftSidebar . toBox+boxInRightSidebar = inRightSidebar . toBox++-- unsafe+fromBox :: GridNode a -> a+fromBox (Box x _) = x++toBox :: a -> GridNode a+toBox x = Box x blankHints++fromContainer :: GridNode a -> [GridNode a]+fromContainer (Container xs _) = xs++toContainer :: [GridNode a] -> GridNode a+toContainer xs = Container xs blankHints++------------------------------+------ Utility functions -----+------------------------------++{- | Separates a list of elements in n lists of list of elements (or n groups), being n the value of the first arg. +     The number of elements in the lists produced is balanced. +     As the number of elements in the orginal group might not be a multiple of n, some lists produced will have one more elements+     than others++     Some examples of the usage of the function:+ +     balancedGroups 3 [1..9] = [[1,2,3],[4,5,6],[7,8,9]]+     balancedGroups 3 [1..10] = [[1,2,3,4],[5,6,7],[8,9,10]]+     balancedGroups 3 [1..11] = [[1,2,3,4],[5,6,7,8],[9,10,11]]+     balancedGroups 3 [1..12] = [[1,2,3,4],[5,6,7,8],[9,10,11,12]]++-}++balancedGroups :: Int -> [a] -> [[a]]+balancedGroups n xs = bigGroups ++ smallGroups+                      where+                        (bigGroups, xs') = iterateNTimes bigGroupsQty (splitAt elemsQtyMax) xs+                        (smallGroups, xs'') = iterateNTimes smallGroupsQty (splitAt elemsQtyMin) xs'+                        elemsQtyMin = xsLength `div` n+                        elemsQtyMax = elemsQtyMin + 1+                        bigGroupsQty = xsLength `mod` n+                        smallGroupsQty = n - bigGroupsQty+                        xsLength = length xs+++iterateNTimes :: Int -> (a -> (b,a)) -> a -> ([b],a)+iterateNTimes 0 f seed = ([],seed)+iterateNTimes n f seed = (x:xs, seed'')+                         where+                            (x, seed') = f seed+                            (xs, seed'') = iterateNTimes (n-1) f seed'+++sortByFst :: Ord a => [(a,b)] -> [(a,b)]+sortByFst = sortBy (comparing fst)++partitionByEq :: Eq b => (a -> b) -> [a] -> [(b,[a])]+partitionByEq f = partitionByEq' . map (\x->(f x, x))++partitionByEq' :: Eq b => [(b,a)] -> [(b,[a])]+partitionByEq' [] = []+partitionByEq' ((y,x): ysxs)+                  = (y, x:inClassY) : partitionByEq' ysxs'+                    where+                         (withY, ysxs') = partition ( (==y) . fst) ysxs+                         inClassY = map snd withY++occurrencies :: Eq a => [a] -> [(a,Int)]+occurrencies [] = []+occurrencies (x:xs) = let (equalsToX,others) = partition (==x) xs+                      in (x, 1 + length equalsToX) : occurrencies others++occurresMost :: Eq a => [a] -> Maybe a+occurresMost xs = case occurrencies xs of+                     [] -> Nothing+                     howManies -> (Just . fst . maximumBy cmp) howManies+                  where+                     cmp (_,x) (_,y) = compare x y+
+ Text/YuiGrid/LayoutHints.hs view
@@ -0,0 +1,92 @@+module Text.YuiGrid.LayoutHints where++import Text.CxML (CssInlineDecl)++data LayoutHints = LayoutHints {+                                inFstSibling :: Bool,+                                cssHints :: [CssInlineDecl],+                                pageAreaHint :: Maybe PageAreaHint,+                                verticalHint :: VerticalHint,+                                columnsQty :: Maybe Int, -- to be used in containers only.+                                columnsQtyVote :: Maybe Int,+                                horizontalHint :: HorizontalHint+                               }++data PageAreaHint = InMain | InHeader | InFooter | InLeftSidebar | InRightSidebar+                    deriving Eq++data VerticalHint = NearTop | Weight Float | NearBottom+                    deriving (Eq, Ord)++data HorizontalHint = ClearSides | NearLeft | HorizWeight Float | NearRight+                      deriving (Eq, Ord)++blankHints :: LayoutHints+blankHints = LayoutHints False [] Nothing (Weight 0) Nothing Nothing (HorizWeight 0)+++class HasLayoutHints a where+  modLayoutHints :: (LayoutHints -> LayoutHints) -> a -> a++setInFstSibling, resetInFstSibling :: HasLayoutHints a => a -> a+setInFstSibling = modLayoutHints (\lhs -> lhs {inFstSibling = True} )+resetInFstSibling = modLayoutHints (\lhs -> lhs {inFstSibling = False} )++addCss :: HasLayoutHints a => CssInlineDecl -> a -> a+addCss (cssId, cssRls) = modLayoutHints (\lhs -> lhs {cssHints = (cssId, cssRls):cssHints lhs} )++resetCss :: HasLayoutHints a => a -> a+resetCss = modLayoutHints (\lhs -> lhs {cssHints = [] } )++setPageAreaHint :: HasLayoutHints a => PageAreaHint -> a -> a+setPageAreaHint pahint = modLayoutHints (\lhs -> lhs {pageAreaHint = Just pahint})++setVerticalHint :: HasLayoutHints a => VerticalHint -> a -> a+setVerticalHint vhint = modLayoutHints (\lhs -> lhs {verticalHint = vhint})++setHorizontalHint :: HasLayoutHints a => HorizontalHint -> a -> a+setHorizontalHint hhint = modLayoutHints (\lhs -> lhs {horizontalHint = hhint})++inMain, inHeader, inFooter, inLeftSidebar, inRightSidebar :: HasLayoutHints a => a -> a+inMain = setPageAreaHint InMain+inHeader = setPageAreaHint InHeader+inFooter = setPageAreaHint InFooter+inLeftSidebar = setPageAreaHint InLeftSidebar+inRightSidebar = setPageAreaHint InRightSidebar++nearTop, nearBottom :: HasLayoutHints a => a -> a+nearTop = setVerticalHint NearTop+nearBottom = setVerticalHint NearBottom++weight :: HasLayoutHints a => Float -> a -> a+weight = setVerticalHint . Weight++setColumns, setColumnsVote :: HasLayoutHints a => Int -> a -> a+setColumns n = modLayoutHints (\lhs -> lhs {columnsQty = Just n})+setColumnsVote n = modLayoutHints (\lhs -> lhs {columnsQtyVote = Just n})++resetColumns, resetColumnsVote :: HasLayoutHints a => a -> a+resetColumns = modLayoutHints (\lhs -> lhs {columnsQty = Nothing})+resetColumnsVote = modLayoutHints (\lhs -> lhs {columnsQtyVote = Nothing})++clearSides, nearLeft, nearRight :: HasLayoutHints a => a -> a+clearSides = setHorizontalHint ClearSides+nearLeft = setHorizontalHint NearLeft+nearRight = setHorizontalHint NearRight++horizWeight :: HasLayoutHints a => Float -> a -> a+horizWeight = setHorizontalHint . HorizWeight+++applyLayouts :: HasLayoutHints a => [a -> a] -> a -> a+applyLayouts = foldl (.) id+++-- Combinators that set specific CSS rules with layout hints++smallMarginBottomCSS, giveBorderCSS :: HasLayoutHints a => a -> a+smallMarginBottomCSS = addCss smallMarginBottomCSSRls+giveBorderCSS = addCss giveBorderCSSRls++smallMarginBottomCSSRls = ("smallMarginBottom", [("margin-bottom","1em")])+giveBorderCSSRls = ("giveBorder", [("border","1px solid black")])
+ Text/YuiGrid/YGrid.hs view
@@ -0,0 +1,84 @@+module Text.YuiGrid.YGrid where++import Text.CxML (CssInlineDecl)++import Text.YuiGrid.LayoutHints+import Text.YuiGrid.Grid++data YPage a = YPage {+                      pageWidth :: YPageWidth,+                      headerBlock :: [YGrid a],+                      mainBlock :: [YGrid a],+                      footerBlock :: [YGrid a],+                      sidebarBlock :: Maybe (YTemplate, [YGrid a])+                     }++-- body is made from mainBlock and sidebarBlock+-- if there are no header and footer, just blocks can be rendered (no header, no footer, no body)+-- if there is no sidebar, blocks don't need to be render, but header and body and  footer might need to be rendered++data YPageWidth = YPW_750px    -- #doc - 750px centered (good for 800x600)+                  | YPW_950px  -- #doc2 - 950px centered (good for 1024x768)+                  | YPW_100perc  -- #doc3 - 100% fluid (good for everybody)+                  | YPW_974px  -- #doc4 - 974px fluid (good for 1024x768)+                  -- YPW_Custom  -- #doc-custom - an example of a custom page width++data YTemplate = SidebarLeft_160px | SidebarLeft_180px | SidebarLeft_300px+                 | SidebarRight_180px | SidebarRight_240px | SidebarRight_300px++data YGrid a =     YGrid_SimpleBox a [CssInlineDecl]+                 | YGrid_ComplexBox [YGrid a] [CssInlineDecl]+                 | YGrid_1Col [YGrid a]+                 | YGrid_2Cols Y_2ColsType [YGrid a] [YGrid a]+                 | YGrid_3Cols [YGrid a] [YGrid a] [YGrid a]+                     -- .yui-gb - Special grid, 1/3 - 1/3 - 1/3++data Y_2ColsType =   Y_1o2_1o2   -- .yui-g - Standard half grid (and nest again for quarters)+                   | Y_2o3_1o3   -- .yui-gc - Special grid, 2/3 - 1/3+                   | Y_1o3_2o3   -- .yui-gd - Special grid, 1/3 - 2/3+                   | Y_3o4_1o4   -- .yui-ge - Special grid, 3/4 - 1/4+                   | Y_1o4_3o4   -- .yui-gf - Special grid, 1/4 - 3/4+++-- for the recursive YGrid cases, in case that any of the YGrid children is not subdivided, it will be rendered as a unit,+-- in case it is subdivided, it will be rendered as a grid.+-- the first child of multi-column grids will be annotated with first, it doesn't matter whether is a unit or grid itself.+++yGridPage :: YPageWidth -> [GridNode a] -> YPage a+yGridPage pageWidth gns = +                case (leftSidebarGNodes, rightSidebarGNodes) of+                   ([],[]) -> YPage pageWidth yHeader yBody yFooter Nothing -- no sidebars+                   (_,[]) -> YPage pageWidth yHeader yBody yFooter (Just (SidebarLeft_160px, yLeftSidebar)) -- left sidebar using template+                   ([],_) -> YPage pageWidth yHeader yBody yFooter (Just (SidebarRight_180px, yRightSidebar)) -- right sidebar using template+                   _ ->  YPage pageWidth yHeader yBodyWithRightSidebar yFooter (Just (SidebarLeft_160px, yLeftSidebar))+                         -- left sidebar using template, right encoded in body+                where+                   (mainGNodes, headerGNodes, footerGNodes, leftSidebarGNodes, rightSidebarGNodes) = gridNodesByPageArea gns+                   yHeader = yGridStack headerGNodes+                   yFooter = yGridStack footerGNodes+                   yLeftSidebar = yGridStack leftSidebarGNodes+                   yRightSidebar = yGridStack rightSidebarGNodes+                   yBody = yGridStack mainGNodes+                   yBodyWithRightSidebar = [YGrid_2Cols Y_3o4_1o4 yBody yRightSidebar]+                   yGridStack = yGrids Nothing++yGrid :: GridNode a -> YGrid a+yGrid (Box x lhs) = YGrid_SimpleBox x (cssHints lhs)+yGrid gn@(Container gns lhs) = YGrid_ComplexBox (yGrids (columnsQty lhs) gns) (cssHints lhs)+                       +yGrids :: Maybe Int -> [GridNode a] -> [YGrid a]+yGrids colSpec = map (yGridCols . gridNodesByColumns colSpec) . splitClearSides . gridNodesVerticalPartitions++yGridCols :: [[GridNode a]] -> YGrid a+yGridCols cols = yGridCols' (map (map yGrid) cols)++yGridCols' :: [[YGrid a]] -> YGrid a+yGridCols' [col1] = YGrid_1Col col1+yGridCols' [col1,col2] = yGrid_2Col col1 col2+yGridCols' [col1,col2,col3] = YGrid_3Cols col1 col2 col3+yGridCols' [col1,col2,col3,col4] = yGrid_2Col [yGrid_2Col col1 col2] [yGrid_2Col col3 col4]+yGridCols' cols = YGrid_1Col (concat cols)++yGrid_2Col = YGrid_2Cols Y_1o2_1o2+
+ Text/YuiGrid/YGridCxML.hs view
@@ -0,0 +1,115 @@+module Text.YuiGrid.YGridCxML (pageToCxML) where++import Prelude hiding (div, span)+import Data.List (nub)++import Text.CxML (CxML, (^%), StyleDecl(..), body, (/-), div, (^#), (^.), CssInlineDecl)+import Text.YuiGrid.YGrid++yahooRls :: [StyleDecl]+yahooRls = [CSSLink (yGridsCSS_URL_Dir ++ yGridsCSS_File), gridsPatchCSSRule]+           where+             yGridsCSS_URL_Dir = "http://yui.yahooapis.com/2.5.2/build/reset-fonts-grids"+--             yGridsCSS_URL_Dir = "" -- Set to use offline (during development), the file needs to be located properly in the file system.+             yGridsCSS_File = "/reset-fonts-grids.css"++             gridsPatchCSSRule = CSSRule [ ".yui-u .yui-g", ".yui-u .yui-gb",+                                        ".yui-u .yui-gc", ".yui-u .yui-gd",+                                        ".yui-u .yui-ge", ".yui-u .yui-gf"+                                      ] [("width","100%")]+++pageToCxML :: YPage (CxML a) -> CxML a+pageToCxML yPage+                = body ^% yahooRls /-+                         [div^#docId^.docClass /-+                                 [+                                  div^#"hd" /- map yGridToCxML (headerBlock yPage),+                                  div^#"bd" /- bd,+                                  div^#"ft" /- map yGridToCxML (footerBlock yPage)+                                 ]+                         ]+                   where+                      docId = case pageWidth yPage of+                                YPW_750px -> "doc"+                                YPW_950px -> "doc2"+                                YPW_100perc -> "doc3"+                                YPW_974px -> "doc4"++                      docClass = case sidebarBlock yPage of+                                   Nothing -> ""+                                   Just (SidebarLeft_160px,_) -> "yui-t1"+                                   Just (SidebarLeft_180px,_) -> "yui-t2"+                                   Just (SidebarLeft_300px,_) -> "yui-t3"+                                   Just (SidebarRight_180px,_) -> "yui-t4"+                                   Just (SidebarRight_240px,_) -> "yui-t5"+                                   Just (SidebarRight_300px,_) -> "yui-t6"++                      bd = case sidebarBlock yPage of+                             Nothing -> theMain+                             Just (_, sidebar) -> [ div^."yui-b" /- map yGridToCxML sidebar,+                                                    div^#"yui-main" /- [div^."yui-b" /- theMain]+                                            ]++                      theMain = map yGridToCxML (mainBlock yPage)++++data Context = NonCtx | FstColCtx | NonFstColCtx++yGridToCxML :: YGrid (CxML a) -> CxML a+yGridToCxML = yGridToCxML' NonCtx++yGridToCxML' :: Context -> YGrid (CxML a) -> CxML a+yGridToCxML' ctx (YGrid_SimpleBox cxml csss) = yMaybeBoxDiv ctx csss [cxml]+yGridToCxML' ctx (YGrid_ComplexBox c1 csss) = yMaybeBoxDiv ctx csss (map yGridToCxML c1)+yGridToCxML' ctx (YGrid_1Col c1) = yMaybeBoxDiv ctx [] (map yGridToCxML c1)+yGridToCxML' ctx g@(YGrid_2Cols _ c1 c2)+             = div^.(yGrdClass ctx g) /- [yFstCol c1, yNonFstCol c2]+yGridToCxML' ctx g@(YGrid_3Cols c1 c2 c3) +             = div^.(yGrdClass ctx g) /- [yFstCol c1, yNonFstCol c2, yNonFstCol c3]+--FIXME: there is space for optimization here or in YGrid, i.e.: +--(YGrid_ComplexBox c1 csss)+--or+--(YGrid_1Col c1) with c1 being singleton. also, might happen to have empty cols?++yFstCol, yNonFstCol :: [YGrid (CxML a)] -> CxML a+yFstCol = yCol FstColCtx+yNonFstCol = yCol NonFstColCtx++yCol :: Context -> [YGrid (CxML a)] -> CxML a+yCol ctx [g] = yGridToCxML' ctx g+   --optimization cases: avoid unecessary <div class="yui-u ..."> when the column has one element+yCol ctx col = yMaybeBoxDiv ctx [] (map yGridToCxML col)++yMaybeBoxDiv :: Context -> [CssInlineDecl] -> [CxML a] -> CxML a+--yMaybeBoxDiv NonCtx [] cxmls = concatCxML cxmls+              -- optimization: div not generated for the box since there are no CSS rules+              -- and it is not a column+yMaybeBoxDiv NonCtx csss cxmls = setCSS csss cxmls+yMaybeBoxDiv ctx csss cxmls = setUnitClass ctx $ div /- [setCSS csss cxmls]++yGrdClass :: Context -> YGrid a -> String+yGrdClass FstColCtx g = yGrdClass' g ++ " first"+yGrdClass _ g = yGrdClass' g++yGrdClass' :: YGrid a -> String+yGrdClass' (YGrid_2Cols Y_1o2_1o2 _ _) = "yui-g"  -- Standard half grid (and nest again for quarters)+yGrdClass' (YGrid_2Cols Y_2o3_1o3 _ _) = "yui-gc" -- Special grid, 2/3 - 1/3+yGrdClass' (YGrid_2Cols Y_1o3_2o3 _ _) = "yui-gd" -- Special grid, 1/3 - 2/3+yGrdClass' (YGrid_2Cols Y_3o4_1o4 _ _) = "yui-ge" -- Special grid, 3/4 - 1/4+yGrdClass' (YGrid_2Cols Y_1o4_3o4 _ _) = "yui-gf" -- Special grid, 1/4 - 3/4+yGrdClass' (YGrid_3Cols _ _ _) = "yui-gb"         -- .yui-gb - Special grid, 1/3 - 1/3 - 1/3+yGrdClass' _ = "" -- just in case some case was forgotten++setUnitClass :: Context -> CxML a -> CxML a+setUnitClass NonCtx cxml = cxml+setUnitClass FstColCtx cxml = cxml^."yui-u first"+setUnitClass NonFstColCtx cxml = cxml^."yui-u"++setCSS :: [CssInlineDecl] -> [CxML a] -> CxML a+setCSS csss cxmls = foldl setCSS' (div /- cxmls) csss++setCSS' :: CxML a -> (String, [(String, String)]) -> CxML a+setCSS' cxml (cssId, rls) = cxml^.cssId^%[CSSRule ['.':cssId] rls]+
+ yuiGrid.cabal view
@@ -0,0 +1,34 @@+Name:               yuiGrid+Version:            0.1+Synopsis:           Grids defined by layout hints and implemented on top of Yahoo grids.+Description:        The grid is specified by boxes, containers and hints telling how these boxes and containers should be laid out. The hints also +                    include CSS specifications. Everything is rendered to html using Yahoo grids through the contextual html combinators+                     (see yahoo grids in  <http://developer.yahoo.com/yui/grids >).+                    The contextual html combinators are also implemented in this package (called CxML here). They allow to keep track of input context +                    and output html parts like inline CSSs, JSs, etc.+Category:           Web+License:            OtherLicense+License-file:       LICENSE+Author:             RedNucleus (see AUTHORS)+Maintainer:         sergio.urinovsky@gmail.com+Stability:          Experimental+Build-Type:         Simple+Build-Depends:      base+Exposed-modules:    Text.CxML,+                    Text.YuiGrid+Other-modules:      Text.CxML.NavList,+                    Text.CxML.HTML,+                    Text.CxML.CSS,+                    Text.CxML.JS,+                    Text.CxML.Tags,+                    Text.CxML.Output,+                    Text.CxML.Types,+                    Text.YuiGrid.LayoutHints,+                    Text.YuiGrid.Grid,+                    Text.YuiGrid.YGrid,+                    Text.YuiGrid.YGridCxML++Extra-source-files: AUTHORS,+                    Example/README, Example/Makefile,+                    Example/GridExample.hs,+                    Example/images/header.gif