diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,3 @@ +Tom Nielsen (tanielsen@gmail.com): Initital design and development. +Sergio Urinovsky (sergio.urinovsky@gmail.com): Design and lead developer. + diff --git a/Example/GridExample.hs b/Example/GridExample.hs new file mode 100644 --- /dev/null +++ b/Example/GridExample.hs @@ -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) + diff --git a/Example/Makefile b/Example/Makefile new file mode 100644 --- /dev/null +++ b/Example/Makefile @@ -0,0 +1,8 @@ +.PHONY: application clean + +application: + ghc -o GridExample --make GridExample.hs + +clean: + -rm GridExample + -rm *.o *.hi *~ diff --git a/Example/README b/Example/README new file mode 100644 --- /dev/null +++ b/Example/README @@ -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/ diff --git a/Example/images/header.gif b/Example/images/header.gif new file mode 100644 Binary files /dev/null and b/Example/images/header.gif differ diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#! /usr/bin/env runhaskell + +>import Distribution.Simple + +>main = defaultMain + diff --git a/Text/CxML.hs b/Text/CxML.hs new file mode 100644 --- /dev/null +++ b/Text/CxML.hs @@ -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 + diff --git a/Text/CxML/CSS.hs b/Text/CxML/CSS.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/CSS.hs @@ -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 ] + diff --git a/Text/CxML/HTML.hs b/Text/CxML/HTML.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/HTML.hs @@ -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) = "<"++escapeBrackets t +escapeBrackets ('>':t) = ">"++escapeBrackets t +escapeBrackets ('&':t) = "&"++escapeBrackets t +escapeBrackets ('\'':t) = "'"++escapeBrackets t +escapeBrackets ('"':t) = "&qout;"++escapeBrackets t +escapeBrackets ('(':'C':')':t) = "©"++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 but src for +(^>) = \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 [] diff --git a/Text/CxML/JS.hs b/Text/CxML/JS.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/JS.hs @@ -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) + + diff --git a/Text/CxML/NavList.hs b/Text/CxML/NavList.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/NavList.hs @@ -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 = "» " + 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 ) + + diff --git a/Text/CxML/Output.hs b/Text/CxML/Output.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/Output.hs @@ -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 = "\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, "\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, "\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, + "});"] +-} diff --git a/Text/CxML/Tags.hs b/Text/CxML/Tags.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/Tags.hs @@ -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" diff --git a/Text/CxML/Types.hs b/Text/CxML/Types.hs new file mode 100644 --- /dev/null +++ b/Text/CxML/Types.hs @@ -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]) diff --git a/Text/YuiGrid.hs b/Text/YuiGrid.hs new file mode 100644 --- /dev/null +++ b/Text/YuiGrid.hs @@ -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 + diff --git a/Text/YuiGrid/Grid.hs b/Text/YuiGrid/Grid.hs new file mode 100644 --- /dev/null +++ b/Text/YuiGrid/Grid.hs @@ -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 + diff --git a/Text/YuiGrid/LayoutHints.hs b/Text/YuiGrid/LayoutHints.hs new file mode 100644 --- /dev/null +++ b/Text/YuiGrid/LayoutHints.hs @@ -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")]) diff --git a/Text/YuiGrid/YGrid.hs b/Text/YuiGrid/YGrid.hs new file mode 100644 --- /dev/null +++ b/Text/YuiGrid/YGrid.hs @@ -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 + diff --git a/Text/YuiGrid/YGridCxML.hs b/Text/YuiGrid/YGridCxML.hs new file mode 100644 --- /dev/null +++ b/Text/YuiGrid/YGridCxML.hs @@ -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
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] + diff --git a/yuiGrid.cabal b/yuiGrid.cabal new file mode 100644 --- /dev/null +++ b/yuiGrid.cabal @@ -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 ). + 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