{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE FlexibleContexts #-}-- | 'Enumeratee's to render XML 'Event's. Unlike libxml-enumerator and-- expat-enumerator, this module does not provide IO and ST variants, since the-- underlying rendering operations are pure functions.moduleText.XML.Stream.Render(renderBuilder,renderBytes,renderText,RenderSettings,def,rsPretty,prettify)whereimportData.XML.Types(Event(..),Content(..),Name(..))importText.XML.Stream.TokenimportqualifiedData.TextasTimportData.Text(Text)importBlaze.ByteString.BuilderimportData.Conduit.Blaze(builderToByteString)importqualifiedData.MapasMapimportData.Map(Map)importData.Maybe(fromMaybe)importData.ByteString(ByteString)importData.Char(isSpace)importData.Default(Default(def))importqualifiedData.SetasSetimportData.List(foldl')importqualifiedData.ConduitasCimportqualifiedData.Conduit.TextasCTimportControl.Exception(assert)importControl.Monad.Trans.Resource(MonadUnsafeIO)-- | Render a stream of 'Event's into a stream of 'ByteString's. This function-- wraps around 'renderBuilder' and 'builderToByteString', so it produces-- optimally sized 'ByteString's with minimal buffer copying.---- The output is UTF8 encoded.renderBytes::MonadUnsafeIOm=>RenderSettings->C.ConduitEventmByteStringrenderBytesrs=renderBuilderrsC.=$=builderToByteString-- | Render a stream of 'Event's into a stream of 'ByteString's. This function-- wraps around 'renderBuilder', 'builderToByteString' and 'renderBytes', so it-- produces optimally sized 'ByteString's with minimal buffer copying.renderText::(C.MonadThrowm,MonadUnsafeIOm)=>RenderSettings->C.ConduitEventmTextrenderTextrs=renderBytesrsC.=$=CT.decodeCT.utf8dataRenderSettings=RenderSettings{rsPretty::Bool}instanceDefaultRenderSettingswheredef=RenderSettings{rsPretty=False}-- | Render a stream of 'Event's into a stream of 'Builder's. Builders are from-- the blaze-builder package, and allow the create of optimally sized-- 'ByteString's with minimal buffer copying.renderBuilder::Monadm=>RenderSettings->C.ConduitEventmBuilderrenderBuilderRenderSettings{rsPretty=True}=prettifyC.=$=renderBuilder'renderBuilderRenderSettings{rsPretty=False}=renderBuilder'renderBuilder'::Monadm=>C.ConduitEventmBuilderrenderBuilder'=C.conduitState(id,[])pushclosewherego'front=maptokenToBuilder$front[]gostack_[]front=(stack,id,go'front)-- we want to wait and see if the next event is the matching endgostackFalse[e@EventBeginElement{}]front=(stack,(e:),go'front)gostackatEnd(EventBeginElementn1as:EventEndElementn2:rest)front|n1==n2=let(token,stack')=mkBeginTokenFalseTruestackn1asingostack'atEndrest(front.token)gostackatEnd(EventBeginElementnameas:rest)front=let(token,stack')=mkBeginTokenFalseFalsestacknameasingostack'atEndrest(front.token)gostackatEnd(e:rest)front=let(token,stack')=eventToTokenstackeingostack'atEndrest(front.token)push(front,stack)es=return$C.StateProducing(leftover,stack')tswhere(stack',leftover,ts)=gostackFalse(front[es])idclose(front,stack)=returntswhere(_,_leftover,ts)=gostackTrue(front[])ideventToToken::Stack->Event->([Token]->[Token],[NSLevel])eventToTokensEventBeginDocument=((:)(TokenBeginDocument[("version",[ContentText"1.0"]),("encoding",[ContentText"UTF-8"])]),s)eventToTokensEventEndDocument=(id,s)eventToTokens(EventInstructioni)=((:)(TokenInstructioni),s)eventToTokens(EventBeginDoctypenmeid)=((:)(TokenDoctypenmeid[]),s)eventToTokensEventEndDoctype=(id,s)eventToTokens(EventCDATAt)=((:)(TokenCDATAt),s)eventToTokens(EventEndElementname)=((:)(TokenEndElement$nameToTNameslname),s')where(sl:s')=seventToTokens(EventContentc)=((:)(TokenContentc),s)eventToTokens(EventCommentt)=((:)(TokenCommentt),s)eventToToken_EventBeginElement{}=error"eventToToken on EventBeginElement"-- mkBeginToken False s name attrstypeStack=[NSLevel]nameToTName::NSLevel->Name->TNamenameToTName_(Namename_(Justpref))|pref=="xml"=TName(Just"xml")namenameToTName_(NamenameNothing_)=TNameNothingname-- invariant that this is truenameToTName(NSLeveldef'sl)(Namename(Justns)_)|def'==Justns=TNameNothingname|otherwise=caseMap.lookupnsslofNothing->error"nameToTName"Justpref->TName(Justpref)namemkBeginToken::Bool-- ^ pretty print attributes?->Bool->Stack->Name->[(Name,[Content])]->([Token]->[Token],Stack)mkBeginTokenisPrettyisClosedsnameattrs=((:)(TokenBeginElementtnametattrs2isClosedindent),ifisClosedthenselsesl2:s)whereindent=ifisPrettythen2+4*lengthselse0prevsl=casesof[]->NSLevelNothingMap.emptysl':_->sl'(sl1,tname,tattrs1)=newElemStackprevslname(sl2,tattrs2)=foldrnewAttrStack(sl1,tattrs1)$nubAttrsattrsnewElemStack::NSLevel->Name->(NSLevel,TName,[TAttribute])newElemStacknsl@(NSLeveldef'_)(Namelocalns_)|def'==ns=(nsl,TNameNothinglocal,[])newElemStack(NSLevel_nsmap)(NamelocalNothing_)=(NSLevelNothingnsmap,TNameNothinglocal,[(TNameNothing"xmlns",[])])newElemStack(NSLevel_nsmap)(Namelocal(Justns)Nothing)=(NSLevel(Justns)nsmap,TNameNothinglocal,[(TNameNothing"xmlns",[ContentTextns])])newElemStack(NSLeveldef'nsmap)(Namelocal(Justns)(Justpref))=caseMap.lookupnsnsmapofJustpref'|pref==pref'->(NSLeveldef'nsmap,TName(Justpref)local,[])_->(NSLeveldef'nsmap',TName(Justpref)local,[(TName(Just"xmlns")pref,[ContentTextns])])wherensmap'=Map.insertnsprefnsmapnewAttrStack::(Name,[Content])->(NSLevel,[TAttribute])->(NSLevel,[TAttribute])newAttrStack(name,value)(NSLeveldef'nsmap,attrs)=(NSLeveldef'nsmap',addNS$(tname,value):attrs)where(nsmap',tname,addNS)=casenameofNamelocalNothing_->(nsmap,TNameNothinglocal,id)Namelocal(Justns)mpref->letppref=fromMaybe"ns"mpref(pref,addNS')=getPrefixpprefnsmapnsin(Map.insertnsprefnsmap,TName(Justpref)local,addNS')getPrefix::Text->MapTextText->Text->(Text,[TAttribute]->[TAttribute])getPrefix__"http://www.w3.org/XML/1998/namespace"=("xml",id)getPrefixpprefnsmapns=caseMap.lookupnsnsmapofJustpref->(pref,id)Nothing->letpref=findUnusedppref$Map.elemsnsmapin(pref,(:)(TName(Just"xmlns")pref,[ContentTextns]))wherefindUnusedxxs|x`elem`xs=findUnused(x`T.snoc`'_')xs|otherwise=x-- | Convert a stream of 'Event's into a prettified one, adding extra-- whitespace. Note that this can change the meaning of your XML.prettify::Monadm=>C.ConduitEventmEventprettify=prettify'0[]prettify'::Monadm=>Int->[Name]->C.ConduitEventmEventprettify'level0names0=C.conduitState(id,(level0,names0))pushclosewherepush(front,a)b=dolet(a',es)=goFalsea(front[b])idreturn$C.StateProducinga'esclose(front,a)=dolet((front',_),es)=goTruea(front[])idassert(null$front'[])$returnesgo_state[]front=((id,state),front[])goatEndstate@(level,_)es@(EventContentt:xs)front=casetakeContents(t:)xsofNothing|notatEnd->(((es++),state),front[])|otherwise->assertFalse$error"Text.XML.Stream.Redner.prettify'"Just(ts,xs')->letts'=mapEventContent$cleanWhitetsts''=ifnullts'then[]elsebeforelevel:ts'++[after]ingoatEndstatexs'(front.(ts''++))goatEnd(level,names)(x:xs)front=dogoatEnd(level',names')xs'(front.chunks)where(chunks,level',names',xs')=case(x,xs)of(EventBeginElementnameattrs,EventEndElement_:rest)->(\a->beforelevel:EventBeginElementnameattrs:EventEndElementname:after:a,level,names,rest)(EventBeginElementnameattrs,_)->(\a->beforelevel:EventBeginElementnameattrs:after:a,level+1,name:names,xs)(EventEndElement_,_)->letnewLevel=level-1n:ns=namesin(\a->beforenewLevel:EventEndElementn:after:a,newLevel,ns,xs)(EventBeginDocument,_)->((EventBeginDocument:),level,names,xs)(EventEndDocument,_)->(\a->EventEndDocument:a,level,names,xs)(EventCommentt,_)->(\a->beforelevel:EventComment(T.mapnormalSpacet):after:a,level,names,xs)(e,_)->(\a->beforelevel:e:after:a,level,names,xs)beforel=EventContent$ContentText$T.replicatel" "after=EventContent$ContentText"\n"takeContents::([Content]->[Content])->[Event]->Maybe([Content],[Event])takeContents_[]=NothingtakeContentsfront(EventContentt:es)=takeContents(front.(t:))estakeContentsfrontes=Just(front[],es)normalSpace::Char->CharnormalSpacec|isSpacec=' '|otherwise=ccleanWhite::[Content]->[Content]cleanWhitex=goTrue[]$goTrue[]xwherego_end(ContentEntitye:rest)=goFalse(ContentEntitye:end)restgoisFrontend(ContentTextt:rest)=ifT.nullt'thengoisFrontendrestelsegoFalse(ContentTextt':end)restwheret'=(ifisFrontthenT.dropWhileisSpaceelseid)$T.mapnormalSpacetgo_end[]=endnubAttrs::[(Name,v)]->[(Name,v)]nubAttrsorig=front[]where(front,_)=foldl'go(id,Set.empty)origgo(dlist,used)(k,v)|k`Set.member`used=(dlist,used)|otherwise=(dlist.((k,v):),Set.insertkused)