-- | These are just some common abbreviations for generating HTML
-- content within the XML transformation framework defined
-- by "Text.Xml.HaXml.Combinators".
module Text.XML.HaXml.Html.Generate
( -- * HTML construction filters
-- ** Containers
html
, hhead
, htitle
, hbody
, h1, h2, h3, h4
, hpara
, hdiv, hspan, margin
-- ** Anchors
, anchor, makehref, anchorname
-- ** Text style
, hpre
, hcentre
, hem, htt, hbold
, parens, bullet
-- ** Tables
, htable, hrow, hcol
-- ** Breaks, lines
, hbr, hhr
-- ** Attributes
, showattr, (!), (?)
-- * A simple HTML pretty-printer
, htmlprint
) where
import Char (isSpace)
import Text.XML.HaXml.Types
import Text.XML.HaXml.Combinators
import qualified Text.PrettyPrint.HughesPJ as Pretty
---- Constructor functions
html, hhead, htitle, hbody, h1, h2, h3, h4, hpara, hpre, hcentre,
hem, htt, hbold, htable, hrow, hcol, hdiv, hspan, margin
:: [CFilter i] -> CFilter i
html = mkElem "html"
hhead = mkElem "head"
htitle = mkElem "title"
hbody = mkElem "body"
h1 = mkElem "h1"
h2 = mkElem "h2"
h3 = mkElem "h3"
h4 = mkElem "h4"
hpara = mkElem "p"
hpre = mkElem "pre"
hcentre = mkElem "center"
hem = mkElem "em"
htt = mkElem "tt"
hbold = mkElem "b"
htable = mkElem "table"
hrow = mkElem "tr"
hcol = mkElem "td"
hdiv = mkElem "div"
hspan = mkElem "span"
margin = mkElemAttr "div" [("margin-left",("2em"!)),
("margin-top", ("1em"!))]
anchor :: [(String, CFilter i)] -> [CFilter i] -> CFilter i
anchor = mkElemAttr "a"
makehref, anchorname :: CFilter i -> [CFilter i] -> CFilter i
makehref r = anchor [ ("href",r) ]
anchorname n = anchor [ ("name",n) ]
hbr, hhr :: CFilter i
hbr = mkElem "br" []
hhr = mkElem "hr" []
showattr, (!), (?) :: String -> CFilter i
showattr n = find n literal
(!) = literal
(?) = showattr
parens :: CFilter i -> CFilter i
parens f = cat [ literal "(", f, literal ")" ]
bullet :: [CFilter i] -> CFilter i
bullet = cat . (literal "M-^U":)
---- Printing function
-- htmlprint :: [Content] -> String
-- htmlprint = concatMap cprint
-- where
-- cprint (CElem e _) = elem e
-- cprint (CString _ s) = s
-- cprint (CMisc m) = ""
--
-- elem (Elem n as []) = "\n<"++n++attrs as++" />"
-- elem (Elem n as cs) = "\n<"++n++attrs as++">"++htmlprint cs++"\n</"++n++">"
--
-- attrs = concatMap attr
-- attr (n,v) = " "++n++"='"++v++"'"
htmlprint :: [Content i] -> Pretty.Doc
htmlprint = Pretty.cat . map cprint . foldrefs
where
foldrefs [] = []
foldrefs (CString ws s1 i:CRef r _:CString _ s2 _:cs) =
CString ws (s1++"&"++ref r++";"++s2) i: foldrefs cs
foldrefs (c:cs) = c : foldrefs cs
--ref (RefEntity (EntityRef n)) = n -- Actually, should look-up symtable.
--ref (RefChar (CharRef s)) = s
ref (RefEntity n) = n -- Actually, should look-up symtable.
ref (RefChar s) = show s
cprint (CElem e _) = element e
cprint (CString ws s _) = Pretty.cat (map Pretty.text (fmt 60
((if ws then id else deSpace) s)))
cprint (CRef r _) = Pretty.text ("&"++ref r++";")
cprint (CMisc _ _) = Pretty.empty
element (Elem n as []) = Pretty.text "<" Pretty.<>
Pretty.text n Pretty.<>
attrs as Pretty.<>
Pretty.text " />"
element (Elem n as cs) =
-- ( Pretty.text "<" Pretty.<>
-- Pretty.text n Pretty.<>
-- attrs as Pretty.<>
-- Pretty.text ">") Pretty.$$
-- Pretty.nest 6 (htmlprint cs) Pretty.$$
-- ( Pretty.text "</" Pretty.<>
-- Pretty.text n Pretty.<>
-- Pretty.text ">" )
Pretty.fcat [ ( Pretty.text "<" Pretty.<>
Pretty.text n Pretty.<>
attrs as Pretty.<>
Pretty.text ">")
, Pretty.nest 4 (htmlprint cs)
, ( Pretty.text "</" Pretty.<>
Pretty.text n Pretty.<>
Pretty.text ">" )
]
attrs = Pretty.cat . map attribute
attribute (n,v@(AttValue _)) =
Pretty.text " " Pretty.<>
Pretty.text n Pretty.<>
Pretty.text "='" Pretty.<>
Pretty.text (show v) Pretty.<>
Pretty.text "'"
fmt _ [] = []
fmt n s = let (top,bot) = splitAt n s
(word,left) = keepUntil isSpace (reverse top)
in if length top < n then [s]
else if not (null left) then
reverse left: fmt n (word++bot)
else let (big,rest) = keepUntil isSpace s
in reverse big: fmt n rest
deSpace [] = []
deSpace (c:cs) | c=='\n' = deSpace (' ':cs)
| isSpace c = c : deSpace (dropWhile isSpace cs)
| otherwise = c : deSpace cs
keepUntil p xs = select p ([],xs)
where select _ (ls,[]) = (ls,[])
select q (ls,(y:ys)) | q y = (ls,y:ys)
| otherwise = select q (y:ls,ys)