-- | A simple abstract type to help create well-formed HTML documents -- -- * Ensure that entities are not escaped twice, e.g @"\<"@ ⟹ @"<"@ ⟹ @"&lt;"@ -- * Ensure that attribute values are quoted when needed -- * Ensure that tags are properly nested module SimpleHTML( HTML,URL,--Tag, (<>),mempty, -- ** Create a complete HTML page page, -- ** HTML5 body parts header,main_,footer, -- ** HTML elements and text h1,h2,h3, p, link,optlink,text, br,hr,nl, -- ** Lists ul,ol,li,Item, -- ** Tables table_class,tr,th,td,Row,Cell, -- ** Forms form,input,submit, -- ** Insert arbitrary markup, no guarantees markup) where import Data.Monoid(Monoid(..)) import Data.Semigroup import Data.Char(isAlphaNum) type URL = String type Tag = String newtype HTML = HTML ShowS instance Show HTML where showsPrec _ (HTML s) = s instance Semigroup HTML where HTML s1 <> HTML s2 = HTML (s1.s2) instance Monoid HTML where mempty = HTML id mappend = (<>) h1 = block "h1" . text h2 = block "h2" . text h3 = block "h3" . text header = block "header" footer = block "footer" main_ = block "main" p e = tag "p" <> e <> nl link :: URL -> HTML -> HTML link url = el' "a" [("href",url)] optlink = maybe id link hr = tag "hr" <> nl br = tag "br" <> nl -------------------------------------------------------------------------------- newtype Item = Item HTML ul items = block "ul" (mconcat [li|Item li<-items]) ol items = block "ol" (mconcat [li|Item li<-items]) li item = Item (tag "li"<> item <> nl) -------------------------------------------------------------------------------- newtype Cell = Cell HTML newtype Row = Row HTML table_class cls rows = block' "table" [("class",cls)] (mconcat [r|Row r<-rows]) tr cells = Row (tag "tr"<>mconcat [c|Cell c<-cells]<>nl) th m = Cell (tag "th"<>m) td m = Cell (tag "td"<>m) -------------------------------------------------------------------------------- block t s = el t s<>nl block' t as s = el' t as s<>nl nl = text "\n" el t s = tag t<>s<>endtag t el' :: Tag -> [(String,String)] -> HTML -> HTML el' t as s = tag' t as<>s<>endtag t tag :: Tag -> HTML tag t = HTML (showChar '<'.showString t.showChar '>') endtag t = tag ('/':t) tag' :: Tag -> [(String,String)] -> HTML tag' t as = tag (t++shas as) where shas = concatMap sha sha (n,v) = ' ':n++"="++quote (esc v) esc :: String->String esc = concatMap esc1 where esc1 '<' = "<" esc1 '>' = ">" esc1 '&' = "&" esc1 c = [c] quote s = if all isAlphaNum s then s else '"':s++"\"" text = HTML . showString . esc markup = HTML . showString -- !!! -- | page title style_url body page :: String -> URL -> HTML -> HTML page title style body = tag "!DOCTYPE html" <> nl <> block "html" (nl <> block "head" (nl <> block "title" (text title)<> tag' "meta" [("charset","UTF-8")] <> nl <> tag' "link" [("rel","stylesheet"),("href",style)]<>nl) <> block "body" (nl<>body)) form :: URL -> HTML -> HTML form action html = el' "form" [("action",action)] html -- | input name placeholder input name ph = tag' "input" [("name",name),("placeholder",ph)] submit label = tag' "input" [("type","submit"),("value",label)] -- ^ submit button_label