-- |-- Module : Data.XCB.FromXML-- Copyright : (c) Antoine Latter 2008-- License : BSD3---- Maintainer: Antoine Latter <aslatter@gmail.com>-- Stability : provisional-- Portability: portable---- Handls parsing the data structures from XML files.---- In order to support copying events and errors across module-- boundaries, all modules which may have cross-module event copies and-- error copies must be parsed at once.---- There is no provision for preserving the event copy and error copy-- declarations - the copies are handled during parsing.moduleData.XCB.FromXML(fromFiles,fromStrings)whereimportData.XCB.TypesimportData.XCB.UtilsimportText.XML.LightimportData.ListasListimportData.MaybeimportControl.MonadimportControl.Monad.ReaderimportSystem.IO(openFile,IOMode(ReadMode),hSetEncoding,utf8,hGetContents)-- |Process the listed XML files.-- Any files which fail to parse are silently dropped.-- Any declaration in an XML file which fail to parse are-- silently dropped.fromFiles::[FilePath]->IO[XHeader]fromFilesxs=dostrings<-sequence$mapreadFileUTF8xsreturn$fromStringsstringsreadFileUTF8::FilePath->IOStringreadFileUTF8fp=doh<-openFilefpReadModehSetEncodinghutf8hGetContentsh-- |Process the strings as if they were XML files.-- Any files which fail to parse are silently dropped.-- Any declaration in an XML file which fail to parse are-- silently dropped.fromStrings::[String]->[XHeader]fromStringsxs=letrs=mapAltfromStringxsJustheaders=runReaderTrsheadersinheaders-- The 'Parse' monad. Provides the name of the-- current module, and a list of all of the modules.typeParse=ReaderT([XHeader],Name)Maybe-- operations in the 'Parse' monadlocalName::ParseNamelocalName=snd`liftM`askallModules::Parse[XHeader]allModules=fst`liftM`ask-- a generic function for looking up something from-- a named XHeader.---- this implements searching both the current module and-- the xproto module if the name is not specified.lookupThingy::([XDecl]->Maybea)->(MaybeName)->Parse(Maybea)lookupThingyfNothing=dolname<-localNameliftM2mplus(lookupThingyf$Justlname)(lookupThingyf$Just"xproto")-- implicit xproto importlookupThingyf(Justmname)=doxs<-allModulesreturn$dox<-findXHeadermnamexsf$xheader_declsx-- lookup an event declaration by name.lookupEvent::MaybeName->Name->Parse(MaybeEventDetails)lookupEventmnameevname=fliplookupThingymname$\decls->findEventevnamedecls-- lookup an error declaration by name.lookupError::MaybeName->Name->Parse(MaybeErrorDetails)lookupErrormnameername=fliplookupThingymname$\decls->findErrorernamedeclsfindXHeader::Name->[XHeader]->MaybeXHeaderfindXHeadername=List.find$\x->xheader_headerx==namefindError::Name->[XDecl]->MaybeErrorDetailsfindErrorpnamexs=caseList.findfxsofNothing->NothingJust(XErrornamecodeelems)->Just$ErrorDetailsnamecodeelems_->error"impossible: fatal error in Data.XCB.FromXML.findError"wheref(XErrorname__)|name==pname=Truef_=FalsefindEvent::Name->[XDecl]->MaybeEventDetailsfindEventpnamexs=caseList.findfxsofNothing->NothingJust(XEventnamecodeelemsnoseq)->Just$EventDetailsnamecodeelemsnoseq_->error"impossible: fatal error in Data.XCB.FromXML.findEvent"wheref(XEventname___)|name==pname=Truef_=FalsedataEventDetails=EventDetailsNameInt[StructElem](MaybeBool)dataErrorDetails=ErrorDetailsNameInt[StructElem]----- extract a single XHeader from a single XML documentfromString::String->ReaderT[XHeader]MaybeXHeaderfromStringstr=doel@(Element_qname_atscnt_)<-lift$parseXMLDocstrguard$el`named`"xcb"header<-el`attr`"header"letname=el`attr`"extension-name"xname=el`attr`"extension-xname"maj_ver=el`attr`"major-version">>=readMmin_ver=el`attr`"minor-version">>=readMmultiword=el`attr`"extension-multiword">>=readM.ensureUpperdecls<-withReaderT(\r->(r,header))$extractDeclscntreturn$XHeader{xheader_header=header,xheader_xname=xname,xheader_name=name,xheader_multiword=multiword,xheader_major_version=maj_ver,xheader_minor_version=min_ver,xheader_decls=decls}-- attempts to extract declarations from XML content, discarding failures.extractDecls::[Content]->Parse[XDecl]extractDecls=mapAltdeclFromElem.onlyElems-- attempt to extract a module declaration from an XML elementdeclFromElem::Element->ParseXDecldeclFromElemel|el`named`"request"=xrequestel|el`named`"event"=xeventel|el`named`"eventcopy"=xevcopyel|el`named`"error"=xerrorel|el`named`"errorcopy"=xercopyel|el`named`"struct"=xstructel|el`named`"union"=xunionel|el`named`"xidtype"=xidtypeel|el`named`"xidunion"=xidunionel|el`named`"typedef"=xtypedefel|el`named`"enum"=xenumel|el`named`"import"=ximportel|otherwise=mzeroximport::Element->ParseXDeclximport=return.XImport.strContentxenum::Element->ParseXDeclxenumel=donm<-el`attr`"name"fields<-mapAltenumField$elChildrenelguard$not$nullfieldsreturn$XEnumnmfieldsenumField::Element->ParseEnumElemenumFieldel=doguard$el`named`"item"name<-el`attr`"name"letexpr=firstChildel>>=expressionreturn$EnumElemnameexprxrequest::Element->ParseXDeclxrequestel=donm<-el`attr`"name"code<-el`attr`"opcode">>=readMfields<-mapAltstructField$elChildrenelletreply=getReplyelreturn$XRequestnmcodefieldsreplygetReply::Element->MaybeXReplygetReplyel=dochildElem<-unqual"reply"`findChild`elletfields=mapMaybestructField$elChildrenchildElemguard$not$nullfieldsreturnfieldsxevent::Element->ParseXDeclxeventel=doname<-el`attr`"name"number<-el`attr`"number">>=readMletnoseq=ensureUpper`liftM`(el`attr`"no-sequence-number")>>=readMfields<-mapAltstructField$elChildrenelguard$not$nullfieldsreturn$XEventnamenumberfieldsnoseqxevcopy::Element->ParseXDeclxevcopyel=doname<-el`attr`"name"number<-el`attr`"number">>=readMref<-el`attr`"ref"-- do we have a qualified ref?let(mname,evname)=splitRefrefdetails<-lookupEventmnameevnamereturn$letEventDetails__fieldsnoseq=casedetailsofNothing->error$"Unresolved event: "++showmname++" "++refJustx->xinXEventnamenumberfieldsnoseq-- we need to do string processing to distinguish qualified from-- unqualified types.mkType::String->TypemkTypestr=let(mname,name)=splitRefstrincasemnameofJustmodifier->QualTypemodifiernameNothing->UnQualTypenamesplitRef::Name->(MaybeName,Name)splitRefref=casesplit':'refof(x,"")->(Nothing,x)(a,b)->(Justa,b)-- |Neither returned string contains the first occurance of the-- supplied Char.split::Char->String->(String,String)splitc=gowherego[]=([],[])go(x:xs)|x==c=([],xs)|otherwise=let(lefts,rights)=goxsin(x:lefts,rights)xerror::Element->ParseXDeclxerrorel=doname<-el`attr`"name"number<-el`attr`"number">>=readMfields<-mapAltstructField$elChildrenelguard$not$nullfieldsreturn$XErrornamenumberfieldsxercopy::Element->ParseXDeclxercopyel=doname<-el`attr`"name"number<-el`attr`"number">>=readMref<-el`attr`"ref"let(mname,ername)=splitRefrefdetails<-lookupErrormnameernamereturn$XErrornamenumber$casedetailsofNothing->error$"Unresolved error: "++showmname++" "++refJust(ErrorDetails__x)->xxstruct::Element->ParseXDeclxstructel=doname<-el`attr`"name"fields<-mapAltstructField$elChildrenelguard$not$nullfieldsreturn$XStructnamefieldsxunion::Element->ParseXDeclxunionel=doname<-el`attr`"name"fields<-mapAltstructField$elChildrenelguard$not$nullfieldsreturn$XUnionnamefieldsxidtype::Element->ParseXDeclxidtypeel=liftMXidType$el`attr`"name"xidunion::Element->ParseXDeclxidunionel=doname<-el`attr`"name"lettypes=mapMaybexidUnionElem$elChildrenelguard$not$nulltypesreturn$XidUnionnametypesxidUnionElem::Element->MaybeXidUnionElemxidUnionElemel=doguard$el`named`"type"return$XidUnionElem$mkType$strContentelxtypedef::Element->ParseXDeclxtypedefel=dooldtyp<-liftMmkType$el`attr`"oldname"newname<-el`attr`"newname"return$XTypeDefnewnameoldtypstructField::MonadPlusm=>Element->mStructElemstructFieldel|el`named`"field"=dotyp<-liftMmkType$el`attr`"type"letenum=liftMmkType$el`attr`"enum"letmask=liftMmkType$el`attr`"mask"name<-el`attr`"name"return$SFieldnametypenummask|el`named`"pad"=dobytes<-el`attr`"bytes">>=readMreturn$Padbytes|el`named`"list"=dotyp<-liftMmkType$el`attr`"type"name<-el`attr`"name"letenum=liftMmkType$el`attr`"enum"letexpr=firstChildel>>=expressionreturn$Listnametypexprenum|el`named`"valueparam"=domask_typ<-liftMmkType$el`attr`"value-mask-type"mask_name<-el`attr`"value-mask-name"letmask_pad=el`attr`"value-mask-pad">>=readMlist_name<-el`attr`"value-list-name"return$ValueParammask_typmask_namemask_padlist_name|el`named`"exprfield"=dotyp<-liftMmkType$el`attr`"type"name<-el`attr`"name"expr<-firstChildel>>=expressionreturn$ExprFieldnametypexpr|el`named`"reply"=fail""-- handled separate|otherwise=letname=elNameelinerror$"I don't know what to do with structelem "++shownameexpression::MonadPlusm=>Element->mExpressionexpressionel|el`named`"fieldref"=return$FieldRef$strContentel|el`named`"value"=Value`liftM`readM(strContentel)|el`named`"bit"=Bit`liftM`don<-readM(strContentel)guard$n>=0returnn|el`named`"op"=dobinop<-el`attr`"op">>=toBinop[exprLhs,exprRhs]<-mapMexpression$elChildrenelreturn$OpbinopexprLhsexprRhs|otherwise=doerror"Unknown epression name in Data.XCB.FromXML.expression"toBinop::MonadPlusm=>String->mBinoptoBinop"+"=returnAddtoBinop"-"=returnSubtoBinop"*"=returnMulttoBinop"/"=returnDivtoBinop"&"=returnAndtoBinop"&amp;"=returnAndtoBinop">>"=returnRShifttoBinop_=mzero---------- Utility functions--------firstChild::MonadPlusm=>Element->mElementfirstChild=listToM.elChildrenlistToM::MonadPlusm=>[a]->malistToM[]=mzerolistToM(x:_)=returnxnamed::Element->String->Boolnamed(Elementqname___)name|qname==unqualname=Truenamed__=Falseattr::MonadPlusm=>Element->String->mString(Element_xs__)`attr`name=caseList.findpxsofJust(Attr_res)->returnres_->mzerowherep(Attrqname_)|qname==unqualname=Truep_=False-- adapted from Network.CGI.ProtocolreadM::(MonadPlusm,Reada)=>String->mareadM=liftMfst.listToM.reads