HTML.hs

{-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving #-}

-- | Library for defining HTML fragments.
--   The tags will be properly nested, and all strings will be HTML escaped.
--   As an example:
--
-- > renderHTML $ html_ $
-- >    ol__ [style_ "color:darkgreen"] $
-- >        forM_ [1..10] $ \i -> li_ $ str_ $ "item number: " & show i
module General.HTML(
    -- * HTML data type
    HTML, HTML_, renderHTML, valueHTML,
    -- * Constructing pieces
    Attribute, attribute_, tag_, tag__, str_, raw_,
    -- * Tags
    br_, style__, link__, hr_,
    pre_, b_, html_, head_, title_, body_, h1_, h2_, ul_, ol_, li_, p_, table_, thead_, tr_, td_, tbody_, i_,
    a__, span__, p__, h2__, tr__, ol__,
    -- * Attributes
    href_, class_, name_, rel_, type_, style_, id_,
    -- * Functions
    (<>),
    url_,
    unlines_, commas_, commasLimit_, header_
    ) where

import Control.Applicative
import Data.Monoid
import Data.List
import Control.Monad
import Control.Monad.Trans.Writer
import Control.DeepSeq
import Data.Char
import Numeric
import Prelude


---------------------------------------------------------------------
-- LIBRARY

data Rope = Branch [Rope] | Leaf String

instance Eq Rope where a == b = renderRope a == renderRope b
instance Ord Rope where compare a b = compare (renderRope a) (renderRope b)

instance NFData Rope where
    rnf (Branch x) = rnf x
    rnf (Leaf x) = rnf x

renderRope :: Rope -> String
renderRope x = f x ""
    where f (Branch []) k = k
          f (Branch (x:xs)) k = f x $ f (Branch xs) k
          f (Leaf x) k = x ++ k

nullRope :: Rope -> Bool
nullRope (Branch xs) = all nullRope xs
nullRope (Leaf x) = null x

instance Monoid Rope where
    mempty = Branch []
    mappend a b = Branch [a,b]
    mconcat = Branch


-- | Escape a URL using % encoding.
url_ :: String -> String
url_ = concatMap f
    where
        f x | (x >= 'A' && x <= 'Z') || (x >= 'a' && x <= 'z') || (x >= '0' && x <= '9') || x `elem` "-_.~" = [x]
        f (ord -> x) = "%" ++ ['0' | x < 16] ++ showHex x ""

-- | The type for constructing HTML. It is a 'Monad' and 'Monoid'.
--   Typically the value paramter is '()', in which case use 'HTML'.
newtype HTML_ a = HTML_ {fromHTML_ :: Writer Rope a}
    deriving (Eq,Ord,Functor,Applicative,Monad)

-- | An alias for 'HTML_' with no interesting type.
type HTML = HTML_ ()

-- | Get the value out of an 'HTML_'.
valueHTML :: HTML_ a -> a
valueHTML = fst . runWriter . fromHTML_

-- | Render some 'HTML'.
renderHTML :: HTML -> String
renderHTML = renderRope . execWriter . fromHTML_

nullHTML :: HTML -> Bool
nullHTML = nullRope . execWriter . fromHTML_

instance Monoid a => Monoid (HTML_ a) where
    mempty = return mempty
    mappend = liftM2 mappend

instance NFData a => NFData (HTML_ a) where
    rnf = rnf . runWriter . fromHTML_

-- | Turn a string into a text fragment of HTML, escaping any characters which mean something in HTML.
str_ :: String -> HTML
str_ = raw_ . escapeHTML

-- | Turn a string into an HTML fragment, applying no escaping. Use this function carefully.
raw_ :: String -> HTML
raw_ = HTML_ . tell . Leaf

escapeHTML :: String -> String
escapeHTML = concatMap $ \c -> case c of
    '<'  -> "&lt;"
    '>'  -> "&gt;"
    '&'  -> "&amp;"
    '\"' -> "&quot;"
    '\'' -> "&#39;"
    x    -> [x]


-- | An attribute for a tag.
data Attribute = Attribute {fromAttribute :: String}

valid (x:xs) | isAlpha x && all isAlphaNum xs = True
valid x = error $ "Not a valid HTML name, " ++ show x

-- | Construct an Attribute from a key and value string. The value will be escaped.
attribute_ :: String -> String -> Attribute
attribute_ a b | valid a = Attribute $ a ++ "=\"" ++ escapeHTML b ++ "\""
               | otherwise = error $ "Invalid attribute name, " ++ a


-- | Given a tag name, a list of attributes, and some content HTML, produce some new HTML.
tag__ :: String -> [Attribute] -> HTML -> HTML
tag__ name at inner | not $ valid name = error $ "Invalid tag name, " ++ name
                    | otherwise = do
    -- if you collapse an "a", it goes wrong
    -- if you don't collapse a "br", it goes wrong
    let zero = nullHTML inner && name `elem` ["br","link"]
    raw_ $
        "<" ++
        unwords (name : map fromAttribute at) ++
        (if zero then " /" else "") ++ ">"
    unless zero $ do
        inner
        raw_ $ "</" ++ name ++ ">"

-- | Like 'tag__' but with no attributes.
tag_ :: String -> HTML -> HTML
tag_ name = tag__ name []


---------------------------------------------------------------------
-- TAGS

br_ = tag_ "br" mempty
hr_ = tag_ "hr" mempty
link__ at = tag__ "link" at mempty
style__ at body = tag__ "style" at $ raw_ body

pre_ = tag_ "pre"
b_ = tag_ "b"
i_ = tag_ "i"
html_ = tag_ "html"
head_ = tag_ "head"
title_ = tag_ "title"
body_ = tag_ "body"
h1_ = tag_ "h1"
h2_ = tag_ "h2"
ul_ = tag_ "ul"
ol_ = tag_ "ol"
li_ = tag_ "li"
p_ = tag_ "p"
table_ = tag_ "table"
thead_ = tag_ "thead"
tr_ = tag_ "tr"
td_ = tag_ "td"
tbody_ = tag_ "tbody"

a__ = tag__ "a"
span__ = tag__ "span"
p__ = tag__ "p"
h2__ = tag__ "h2"
tr__ = tag__ "tr"
ol__ = tag__ "ol"

href_ = attribute_ "href"
class_ = attribute_ "class"
name_ = attribute_ "name"
rel_ = attribute_ "rel"
type_ = attribute_ "type"
style_ = attribute_ "style"
id_ = attribute_ "id"

unlines_ = mconcat . map (<> str_ "\n")
commas_ = mconcat . intersperse (str_ ", ")
commasLimit_ = limit_ commas_

limit_ :: ([HTML] -> HTML) -> Int -> [HTML] -> HTML
limit_ rejoin i xs = rejoin a <> str_ (if null b then "" else "...")
    where (a,b) = splitAt i xs


-- FIXME: hack, very much app-specific
header_ :: String -> String -> HTML
header_ tag x = a__ [id_ tag,href_ $ "#" ++ tag,class_ "self"] $ h2_ $ str_ x