{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE PatternGuards #-}moduleText.XmlHtml.HTML.RenderwhereimportBlaze.ByteString.BuilderimportControl.ApplicativeimportData.MaybeimportData.MonoidimportqualifiedText.ParsecasPimportText.XmlHtml.CommonimportText.XmlHtml.TextParserimportText.XmlHtml.HTML.MetaimportqualifiedText.XmlHtml.HTML.ParseasPimportText.XmlHtml.XML.Render(docTypeDecl,entity)importData.Text(Text)importqualifiedData.TextasTimportqualifiedData.HashSetasS-------------------------------------------------------------------------------- | And, the rendering code.render::Encoding->MaybeDocType->[Node]->Builderrenderedtns=byteOrder`mappend`docTypeDecledt`mappend`nodeswherebyteOrder|isUTF16e=fromTexte"\xFEFF"-- byte order mark|otherwise=memptynodes|nullns=mempty|otherwise=firstNodee(headns)`mappend`(mconcat$map(nodee)(tailns))-------------------------------------------------------------------------------- | Function for rendering HTML nodes without the overhead of creating a-- Document structure.renderHtmlFragment::Encoding->[Node]->BuilderrenderHtmlFragment_[]=memptyrenderHtmlFragmente(n:ns)=firstNodeen`mappend`(mconcat$map(nodee)ns)-------------------------------------------------------------------------------- | HTML allows & so long as it is not "ambiguous" (i.e., looks like an-- entity). So we have a special case for that.escaped::[Char]->Encoding->Text->Builderescaped__""=memptyescapedbadet=let(p,s)=T.break(`elem`bad)tr=T.unconssinfromTextep`mappend`caserofNothing->memptyJust('&',ss)|isLeft(parseTextambigAmp""s)->fromTexte"&"`mappend`escapedbadessJust(c,ss)->entityec`mappend`escapedbadesswhereisLeft=either(constTrue)(constFalse)ambigAmp=P.char'&'*>(P.finishCharRef*>return()<|>P.finishEntityRef*>return())------------------------------------------------------------------------------node::Encoding->Node->Buildernodee(TextNodet)=escaped"<>&"etnodee(Commentt)|"--"`T.isInfixOf`t=error"Invalid comment"|"-"`T.isSuffixOf`t=error"Invalid comment"|otherwise=fromTexte"<!--"`mappend`fromTextet`mappend`fromTexte"-->"nodee(Elementtac)=lettbase=T.toLower$snd$T.breakOnEnd":"tinelementettbaseac-------------------------------------------------------------------------------- | Process the first node differently to encode leading whitespace. This-- lets us be sure that @parseHTML@ is a left inverse to @render@.firstNode::Encoding->Node->BuilderfirstNodee(Commentt)=nodee(Commentt)firstNodee(Elementtac)=nodee(Elementtac)firstNode_(TextNode"")=memptyfirstNodee(TextNodet)=let(c,t')=fromJust$T.unconstinescaped"<>& \t\r\n"e(T.singletonc)`mappend`nodee(TextNodet')-------------------------------------------------------------------------------- XXX: Should do something to avoid concatting large CDATA sections before-- writing them to the output.element::Encoding->Text->Text->[(Text,Text)]->[Node]->Builderelementettbac|tb`S.member`voidTags&&nullc=fromTexte"<"`mappend`fromTextet`mappend`(mconcat$map(attributee)a)`mappend`fromTexte" />"|tb`S.member`voidTags=error$T.unpackt++" must be empty"|tb`S.member`rawTextTags,allisTextNodec,lets=T.concat(mapnodeTextc),not("</"`T.append`t`T.isInfixOf`s)=fromTexte"<"`mappend`fromTextet`mappend`(mconcat$map(attributee)a)`mappend`fromTexte">"`mappend`fromTextes`mappend`fromTexte"</"`mappend`fromTextet`mappend`fromTexte">"|tb`S.member`rawTextTags,[TextNode_]<-c=error$T.unpackt++" cannot contain text looking like its end tag"|tb`S.member`rawTextTags=error$T.unpackt++" cannot contain child elements or comments"|otherwise=fromTexte"<"`mappend`fromTextet`mappend`(mconcat$map(attributee)a)`mappend`fromTexte">"`mappend`(mconcat$map(nodee)c)`mappend`fromTexte"</"`mappend`fromTextet`mappend`fromTexte">"------------------------------------------------------------------------------attribute::Encoding->(Text,Text)->Builderattributee(n,v)|v==""=fromTexte" "`mappend`fromTexten|not("\'"`T.isInfixOf`v)=fromTexte" "`mappend`fromTexten`mappend`fromTexte"=\'"`mappend`escaped"&"ev`mappend`fromTexte"\'"|otherwise=fromTexte" "`mappend`fromTexten`mappend`fromTexte"=\""`mappend`escaped"&\""ev`mappend`fromTexte"\""