module XHTML ( module XML,
ii, bb, tt, sup, -- make [XML] into italic, tt, sup, or bold XML
pp, h1, h2, h3, h4, -- turn [XML] into top-level HTML element
br, --
aa, -- target linkname --> XML link
lnk, -- target cs --> XML cs
img, -- src --> 
imgSrcAlt, -- src alt -->
imgWith, -- ats --> ![]()
hbody, -- ats cs --> cs
showXHTML,
showXHTMLs,
table1row,
rowize,
matrix2table,
matrix2tableClass ) where
import XML
import Maybe
import PPrint
-- markuppers
ii, bb, tt :: [XML] -> XML
ii = around "i"
bb = around "b"
tt = around "tt"
sup = around "sup"
-- different kinds of paragraphs
pre, pp, h1, h2, h3, h4 :: [XML] -> XML
pp = around "p"
h1 = around "h1"
h2 = around "h2"
h3 = around "h3"
h4 = around "h4"
pre = around "pre"
-- links and images
aa :: String -> String -> XML
aa target linkname = target `lnk` [txt linkname]
lnk :: String -> [XML] -> XML
lnk target cs = elm "a" ["href"-->target] cs
br :: XML
br = "br" `around` []
img :: String -> XML
img s = imgWith ["src"-->s]
imgSrcAlt :: String -> String -> XML
imgSrcAlt s a = imgWith ["src"-->s, "alt"-->a]
imgWith :: [XML.Att] -> XML
imgWith ats = "img" `with` src : alt : border : ats'
where ats' = ats `without` ["src", "border", "alt"]
alt = defaulter "alt" (rhs src)
src = defaulter "src" "no source"
border = defaulter "border" "0"
defaulter k v = k --> (fromMaybe v (getAtt k ats)) -- only if doesn't exist in ats
without origAts removelabels = filter (\x -> (lhs x) `notElem` removelabels) origAts
rhs (Att _ rh) = rh
lhs (Att lh _) = lh
getAtt :: String -> [Att] -> Maybe String
getAtt attName list = listToMaybe (map rhs (filter matcher list))
where matcher (Att key val) = key==attName
rowize :: [XMLs] -> XML
rowize r = "tr" `around` tds
where tds = (map (\x->"td" `around` x) r)
table1row :: XMLs -> XML
table1row rs = "table" `around` [rowize (map (:[]) rs)]
matrix2table :: [[XMLs]] -> XML
matrix2table rs = "table" `around` (map rowize rs)
matrix2tableClass :: String -> [[XMLs]] -> XML
matrix2tableClass c rs = elm "table" ["class"-->c] (map rowize rs)
hbody ats cs = elm "body" ats cs
-- because HTML //IS ACTUALLY// space/indentation/newline sensitive!!!!
-- adding 'optional' whitespace/indentation/newlines between raw text and a
-- tag can sometimes have different meaning
-- e.g. this text
-- ---this means that we have to be tight where there's raw
-- text nearby, but we can loosen up and make a more indented
-- nicer shape everywhere else
isTxt (Text _) = True
isTxt _ = False
rawEnough (Text _) = True
rawEnough (Comm _ _ _) = True
rawEnough (Elm "textarea" _ _) = True
rawEnough (Elm _ _ cs) = or $ map isTxt cs
rawEnough (Hole x) = error $ "Holes shouldn't get through! ==> " ++ show x
xhtmls2doc :: [XML] -> Doc
xhtmls2doc xs = glueHard $ map xhtml2doc xs
xhtml2doc x | rawEnough x = tightXML2doc x
| otherwise = looseXML2doc x
tightXML2doc :: XML -> Doc
tightXML2doc e@(Comm l ss r) = xml2doc e --text l <> align (vsep ((map text ss) )) <> text r
--this should stay as xml2doc (not XHTML2doc) because this happened to loop forever...
tightXML2doc (Text " ") = softline
tightXML2doc (Text "\n") = softline
tightXML2doc (Text t) = text t
-- textarea problems...
tightXML2doc (Elm n@("textarea") ats [Text s]) =
text"<"<>text n<> attrs2doc ats<> text ">"<> text s <>text" text n <> text ">"
-- hacks for IE sucking... (problems in the element)
-- doesn't work so we make it
tightXML2doc (Elm n@("script") ats [])
= text"<"<>text n<> attrs2doc ats<> text"> text n <> text ">"
-- same for link
tightXML2doc (Elm n@("link") ats []) =
text"<"<>text n<> attrs2doc ats<> text"> text n <> text ">"
tightXML2doc (Elm n ats []) = text"<"<>text n<> attrs2doc ats<> text" />" <> softbreak
-- change ...
arbitrary junk to ...
where arbitrary junk gets thrown away
tightXML2doc e@(Elm "p" _ ((ee@(Elm "p" _ cs)):_)) = wrap ee guts
where guts = (glue $ map xhtml2doc cs) -- <> linebreak
-- change arbitrary junk to where arbitrary junk gets thrown away
tightXML2doc e@(Elm "p" _ ((ee@(Elm "form" _ cs)):_)) = wrap ee guts
where guts = (glue $ map xhtml2doc cs) -- <> linebreak
-- TODO was xml2doc --^ here
tightXML2doc e@(Elm _ _ cs) = wrap e guts
where guts = (glue $ map xhtml2doc cs) -- <> linebreak
looseXML2doc (Text _) = error "txt node is never considered loose"
looseXML2doc e@(Comm l ss r) = xhtml2doc e --text l <+> align (vsep ((map text ss) ++ [text r]))
-- TODO was xhtml2doc --^ here
looseXML2doc e@(Elm _ _ []) = tightXML2doc e
-- change arbitrary junk to where arbitrary junk gets thrown away
looseXML2doc e@(Elm "p" _ ((ee@(Elm "form" _ cs)):_)) = wrap ee (linebreak <> looseXMLs2doc cs)
looseXML2doc e@(Elm _ _ cs) = wrap e (linebreak <> looseXMLs2doc cs)
looseXMLs2doc :: [XML] -> Doc
looseXMLs2doc xs = glueHard $ map xhtml2doc xs
showXHTMLs w d = displayS (renderPretty 1.0 w (xhtmls2doc d)) ""
showXHTML w d = displayS (renderPretty 1.0 w (xhtml2doc d)) ""
--showXHTMLs w d = displayS (renderPretty 1.0 w (xhtmls2doc d)) ""
--showXML w d = displayS (renderPretty 1.0 w (xhtml2doc d)) ""
--showXMLs w d = displayS (renderPretty 1.0 w (xhtmls2doc d)) ""