{-# 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,mapMaybe)importData.ByteString(ByteString)importData.Default(Default(def))importqualifiedData.SetasSetimportData.List(foldl')importqualifiedData.ConduitasCimportData.Conduit.Internal(sinkToPipe)importqualifiedData.Conduit.ListasCLimportqualifiedData.Conduit.TextasCTimportControl.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'TruerenderBuilderRenderSettings{rsPretty=False}=renderBuilder'FalserenderBuilder'::Monadm=>Bool->C.ConduitEventmBuilderrenderBuilder'isPretty=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')=mkBeginTokenisPrettyTruestackn1asingostack'atEndrest(front.token)gostackatEnd(EventBeginElementnameas:rest)front=let(token,stack')=mkBeginTokenisPrettyFalsestacknameasingostack'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'0prettify'::Monadm=>Int->C.ConduitEventmEventprettify'level=dome<-C.awaitcasemeofNothing->return()Juste->goewheregoe@EventBeginDocument=doC.yieldeC.yield$EventContent$ContentText"\n"prettify'levelgoe@EventBeginElement{}=doC.yieldbeforeC.yieldemnext<-sinkToPipeCL.peekcasemnextofJustnext@EventEndElement{}->dosinkToPipe$CL.drop1C.yieldnextC.yieldafterprettify'level_->doC.yieldafterprettify'$level+1goe@EventEndElement{}=doletlevel'=max0$level-1C.yield$before'level'C.yieldeC.yieldafterprettify'level'go(EventContentc)=docs<-sinkToPipe$takeContents(c:)letcs'=mapMaybenormalizecscasecs'of[]->return()_->doC.yieldbeforemapM_(C.yield.EventContent)cs'C.yieldafterprettify'levelgo(EventCDATAt)=go$EventContent$ContentTexttgoe@EventInstruction{}=doC.yieldbeforeC.yieldeC.yieldafterprettify'levelgo(EventCommentt)=doC.yieldbeforeC.yield$EventComment$T.concat[" ",T.unwords$T.wordst," "]C.yieldafterprettify'levelgoe@EventEndDocument=C.yielde>>prettify'levelgoe@EventBeginDoctype{}=C.yielde>>prettify'levelgoe@EventEndDoctype{}=C.yielde>>C.yieldafter>>prettify'leveltakeContentsfront=dome<-CL.peekcasemeofJust(EventContentc)->doCL.drop1takeContents$front.(c:)Just(EventCDATAt)->doCL.drop1takeContents$front.(ContentTextt:)_->return$front[]normalize(ContentTextt)|T.nullt'=Nothing|otherwise=Just$ContentTextt'wheret'=T.unwords$T.wordstnormalizec=Justcbefore=EventContent$ContentText$T.replicatelevel" "before'l=EventContent$ContentText$T.replicatel" "after=EventContent$ContentText"\n"nubAttrs::[(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)