Html.hs

{-# LANGUAGE FlexibleInstances #-}
module PivotalTeam.Html where

import Happstack.Server
import Text.XHtml.Strict 

import PivotalTeam.State

instance HTML (TeamMember, Bool) where
    toHtml (TeamMember n _, b) =
        li ! [theclass (if b then "alt" else "")] <<
           strong << n

instance HTML Team where
    toHtml (Team tms) =
        thediv <<
          (h2 ! [identifier "comments", theclass "h2comment"] << "Team" +++
          thediv ! [theclass "clear"] << "" +++
          ulist ! [theclass "commentlist"] <<
            toHtmlFromList (zip tms (cycle [False,True])))

renderPageTemplate :: String -> Html -> ServerPartT IO Response
renderPageTemplate t m = ok $ toResponse $ pageTemplate t m

pageTemplate :: String -> Html -> Html
pageTemplate t main =
    thehtml <<
      htmlHeader t +++
      body <<
           theHeader +++
           theSideBar +++
           theMain main +++
           theFooter

htmlHeader :: String -> Html
htmlHeader t =
    header <<
      (thetitle << t +++ 
       meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] +++
       thelink ! [ rel "stylesheet"
                 , thetype "text/css"
                 , href "/theme/style.css", strAttr "media" "screen"] << "")

theHeader :: Html
theHeader =
    thediv ! [identifier "header"] << 
      (thediv ! [theclass "grunge"] << "" +++
       thediv ! [theclass "topnavi"] <<
       ulist <<
         li ! [theclass "current_page_item"] <<
           anchor ! [href "/", title "PivotalTeam"] << "PivotalTeam")

theSideBar :: Html
theSideBar =
    thediv ! [theclass "side1"] <<
      thediv ! [theclass "sbar_section"] <<
        (h2 << "Links" +++
         ulist <<
           li ! [theclass "cat-item cat-item-1"] <<
             anchor ! [href "http://happstack.com/"] << "Happstack" +++
           li ! [theclass "cat-item cat-item-2"] <<
             anchor ! [href "http://happstack.com/tutorials"] << "Happstack Tutorials")

theMain :: Html -> Html
theMain main = 
    thediv ! [theclass "wrap"] <<
      thediv ! [theclass "innercont_main"] << main


theFooter :: Html
theFooter = 
    thediv ! [theclass "footer"] <<
      (thediv ! [theclass "finalfooter"] <<
       ("Theme: " +++
        anchor ! [href "http://www.dezinerfolio.com/2007/10/10/just-another-wodpress-theme", title "sIMPRESS v2 theme"] << "sIMPRESS v2" +++
        " by " +++
        anchor ! [href "http://dezinerfolio.com", title "Dezinerfolio"] << "Dezinerfolio"))
                    

postTemplate :: String -> Html -> Html
postTemplate postTitle c =         
    thediv ! [theclass "post"] <<
      thediv ! [theclass "posttop"] <<
        (h1 ! [theclass "posttitle"] << postTitle +++
        thediv ! [theclass "storycontent"] <<
          p << c)