clckwrks-0.13.0: HSP/HTMLBuilder.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  HSP.HTML
-- Copyright   :  (c) Niklas Broberg, Jeremy Shaw 2008
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se
-- Stability   :  experimental
-- Portability :  Haskell 98
--
-- Attempt to render XHTML as well-formed HTML 4.01:
--
--  1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>
--
--  2. the end tag is forbidden for some elements, for these we:
--
--    * render only the open tag, e.g., \<br\>
--
--    * throw an error if the tag contains children
--
--  3. optional end tags are always rendered
--
-- Currently no validation is performed.
-----------------------------------------------------------------------------
module HSP.HTMLBuilder (
                  Style(..)
                 -- * Functions
                , renderAsHTML
                , htmlEscapeChars
                ) where

import Data.List
import Data.Monoid (mappend, mconcat, mempty)
import Data.Text.Lazy (unpack)
import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText)
import HSP.XML
import HSP.XML.PCDATA(escaper)

-- | Pretty-prints HTML values.
--
-- Error Handling:
--
-- Some tags (such as img) can not contain children in HTML. However,
-- there is nothing to stop the caller from passing in XML which
-- contains an img tag with children. There are three basic ways to
-- handle this:
--
--  1. drop the bogus children silently
--
--  2. call 'error' \/ raise an exception
--
--  3. render the img tag with children -- even though it is invalid
--
-- Currently we are taking approach #3, since no other attempts to
-- validate the data are made in this function. Instead, you can run
-- the output through a full HTML validator to detect the errors.
--
-- #1 seems like a poor choice, since it makes is easy to overlook the
-- fact that data went missing.
--
-- We could raising errors, but you have to be in the IO monad to
-- catch them. Also, you have to use evaluate if you want to check for
-- errors. This means you can not start sending the page until the
-- whole page has been rendered. And you have to store the whole page
-- in RAM at once. Similar problems occur if we return Either
-- instead. We mostly care about catching errors and showing them in
-- the browser during testing, so perhaps this can be configurable.
--
-- Another solution would be a compile time error if an empty-only
-- tag contained children.
--
-- FIXME: also verify that the domain is correct
--
-- FIXME: what to do if a namespace is encountered

renderAsHTML :: Style -> XML -> Builder
renderAsHTML style xml = renderAsHTML' style 0 xml

data TagType = Open | Close

data Style = Compact | Expanded

renderAsHTML' :: Style -> Int -> XML -> Builder
renderAsHTML' _ _ (CDATA needsEscape cd) = fromString (if needsEscape then (escaper htmlEscapeChars cd) else cd)

renderAsHTML' style n elm@(Element name@(Nothing,nm) attrs children)
    | nm == "area"	= renderTagEmpty children
    | nm == "base"	= renderTagEmpty children
    | nm == "br"        = renderTagEmpty children
    | nm == "col"       = renderTagEmpty children
    | nm == "hr"        = renderTagEmpty children
    | nm == "img"       = renderTagEmpty children
    | nm == "input"     = renderTagEmpty children
    | nm == "link"      = renderTagEmpty children
    | nm == "meta"      = renderTagEmpty children
    | nm == "param"     = renderTagEmpty children
    | nm == "script"    = renderElement style n (Element name attrs (map asCDATA children))
    | nm == "style"     = renderElement style n (Element name attrs (map asCDATA children))
    where
      renderTagEmpty [] = renderTag style Open n name attrs
      renderTagEmpty _ = renderElement style n elm -- this case should not happen in valid HTML
      -- for and script\/style, render text in element as CDATA not PCDATA
      asCDATA :: XML -> XML
      asCDATA (CDATA _ cd) = (CDATA False cd)
      asCDATA o = o -- this case should not happen in valid HTML
renderAsHTML' style n e = renderElement style n e

renderElement :: Style -> Int -> XML -> Builder
renderElement style n (Element name attrs children) =
        let open  = renderTag style Open n name attrs
            cs    = renderChildren n children
            close = renderTag style Close n name []
         in mconcat [open, cs, close]
  where renderChildren :: Int -> Children -> Builder
        renderChildren n' cs = mconcat $ map (renderAsHTML' style (n'+2)) cs
renderElement _ _ _ = error "internal error: renderElement only suports the Element constructor."


renderTag :: Style -> TagType -> Int -> Name -> Attributes -> Builder
renderTag style typ n name attrs =
        let (start,end) = case typ of
                           Open   -> (singleton  '<' , singleton '>')
                           Close  -> (fromString "</", singleton '>')
            nam = showName name
            as  = renderAttrs attrs
         in mconcat [start, nam, as, end]

  where renderAttrs :: Attributes -> Builder
        renderAttrs [] = nl
        renderAttrs attrs' = mconcat [singleton ' ', ats, nl]
          where ats = mconcat $ intersperse (singleton ' ') $ fmap renderAttr attrs'

        renderAttr :: Attribute -> Builder
        renderAttr (MkAttr (nam, (Value needsEscape val))) =
            mconcat [ showName nam, singleton '=', renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else val)]

        renderAttrVal :: String -> Builder
        renderAttrVal s =
            mconcat [singleton '\"', fromString s, singleton '\"']

        showName (Nothing, s) = fromString s
        showName (Just d, s)  = mconcat [fromString d, singleton ':', fromString s]

        nl =
            case style of
              Compact  -> mempty
              Expanded -> singleton '\n' `mappend` (fromString $ replicate n ' ')

-- This list should be extended.
htmlEscapeChars :: [(Char, String)]
htmlEscapeChars = [
	('&',	"amp"	),
	('\"',	"quot"	),
	('<',	"lt"	),
	('>',	"gt"	)
	]