{-# LANGUAGE OverloadedStrings #-}-- Copyright (C) 2009-2012 John Millikin <jmillikin@gmail.com>---- This program is free software: you can redistribute it and/or modify-- it under the terms of the GNU General Public License as published by-- the Free Software Foundation, either version 3 of the License, or-- any later version.---- This program is distributed in the hope that it will be useful,-- but WITHOUT ANY WARRANTY; without even the implied warranty of-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the-- GNU General Public License for more details.---- You should have received a copy of the GNU General Public License-- along with this program. If not, see <http://www.gnu.org/licenses/>.moduleDBus.Introspection(-- * XML conversionparseXML,formatXML-- * Objects,Object,object,objectPath,objectInterfaces,objectChildren-- * Interfaces,Interface,interface,interfaceName,interfaceMethods,interfaceSignals,interfaceProperties-- * Methods,Method,method,methodName,methodArgs-- ** Method arguments,MethodArg,methodArg,methodArgName,methodArgType,methodArgDirection,Direction,directionIn,directionOut-- * Signals,Signal,signal,signalName,signalArgs-- ** Signal arguments,SignalArg,signalArg,signalArgName,signalArgType-- * Properties,Property,property,propertyName,propertyType,propertyRead,propertyWrite)whereimportControl.Monad((>=>))importControl.Monad.ST(runST)importData.List(isPrefixOf)importqualifiedData.STRefasSTimportqualifiedData.TextimportData.Text(Text)importqualifiedData.Text.EncodingimportqualifiedData.XML.TypesasXimportqualifiedText.XML.LibXML.SAXasSAXimportqualifiedDBusasTdataObject=Object{objectPath::T.ObjectPath,objectInterfaces::[Interface],objectChildren::[Object]}deriving(Show,Eq)object::T.ObjectPath->Objectobjectpath=Objectpath[][]dataInterface=Interface{interfaceName::T.InterfaceName,interfaceMethods::[Method],interfaceSignals::[Signal],interfaceProperties::[Property]}deriving(Show,Eq)interface::T.InterfaceName->Interfaceinterfacename=Interfacename[][][]dataMethod=Method{methodName::T.MemberName,methodArgs::[MethodArg]}deriving(Show,Eq)method::T.MemberName->Methodmethodname=Methodname[]dataMethodArg=MethodArg{methodArgName::String,methodArgType::T.Type,methodArgDirection::Direction}deriving(Show,Eq)methodArg::String->T.Type->Direction->MethodArgmethodArg=MethodArgdataDirection=In|Outderiving(Show,Eq)directionIn::DirectiondirectionIn=IndirectionOut::DirectiondirectionOut=OutdataSignal=Signal{signalName::T.MemberName,signalArgs::[SignalArg]}deriving(Show,Eq)signal::T.MemberName->Signalsignalname=Signalname[]dataSignalArg=SignalArg{signalArgName::String,signalArgType::T.Type}deriving(Show,Eq)signalArg::String->T.Type->SignalArgsignalArg=SignalArgdataProperty=Property{propertyName::String,propertyType::T.Type,propertyRead::Bool,propertyWrite::Bool}deriving(Show,Eq)property::String->T.Type->Propertypropertynamet=PropertynametFalseFalseparseXML::T.ObjectPath->String->MaybeObjectparseXMLpathxml=doroot<-parseElement(Data.Text.packxml)parseRootpathrootparseElement::Text->MaybeX.ElementparseElementxml=runST$dostackRef<-ST.newSTRef[([],[])]letonError_=doST.writeSTRefstackRef[]returnFalseletonBegin_attrs=doST.modifySTRefstackRef((attrs,[]):)returnTrueletonEndname=dostack<-ST.readSTRefstackReflet(attrs,children'):stack'=stacklete=X.Elementnameattrs(mapX.NodeElement(reversechildren'))let(pAttrs,pChildren):stack''=stack'letparent=(pAttrs,e:pChildren)ST.writeSTRefstackRef(parent:stack'')returnTruep<-SAX.newParserSTNothingSAX.setCallbackpSAX.parsedBeginElementonBeginSAX.setCallbackpSAX.parsedEndElementonEndSAX.setCallbackpSAX.reportErroronErrorSAX.parseBytesp(Data.Text.Encoding.encodeUtf8xml)SAX.parseCompletepstack<-ST.readSTRefstackRefreturn$casestackof[]->Nothing(_,children'):_->Just(headchildren')parseRoot::T.ObjectPath->X.Element->MaybeObjectparseRootdefaultPathe=dopath<-caseX.attributeText"name"eofNothing->JustdefaultPathJustx->T.parseObjectPath(Data.Text.unpackx)parseObjectpatheparseChild::T.ObjectPath->X.Element->MaybeObjectparseChildparentPathe=doletparentPath'=caseT.formatObjectPathparentPathof"/"->"/"x->x++"/"pathSegment<-X.attributeText"name"epath<-T.parseObjectPath(parentPath'++Data.Text.unpackpathSegment)parseObjectpatheparseObject::T.ObjectPath->X.Element->MaybeObjectparseObjectpathe|X.elementNamee=="node"=dointerfaces<-childrenparseInterface(X.isNamed"interface")echildren'<-children(parseChildpath)(X.isNamed"node")ereturn(Objectpathinterfaceschildren')parseObject__=NothingparseInterface::X.Element->MaybeInterfaceparseInterfacee=doname<-T.parseInterfaceName=<<attributeString"name"emethods<-childrenparseMethod(X.isNamed"method")esignals<-childrenparseSignal(X.isNamed"signal")eproperties<-childrenparseProperty(X.isNamed"property")ereturn(Interfacenamemethodssignalsproperties)parseMethod::X.Element->MaybeMethodparseMethode=doname<-T.parseMemberName=<<attributeString"name"eargs<-childrenparseMethodArg(isArg["in","out",""])ereturn(Methodnameargs)parseSignal::X.Element->MaybeSignalparseSignale=doname<-T.parseMemberName=<<attributeString"name"eargs<-childrenparseSignalArg(isArg["out",""])ereturn(Signalnameargs)parseType::X.Element->MaybeT.TypeparseTypee=dotypeStr<-attributeString"type"esig<-T.parseSignaturetypeStrcaseT.signatureTypessigof[t]->Justt_->NothingparseMethodArg::X.Element->MaybeMethodArgparseMethodArge=dot<-parseTypeeletdir=casegetattr"direction"eof"out"->Out_->InJust(MethodArg(getattr"name"e)tdir)parseSignalArg::X.Element->MaybeSignalArgparseSignalArge=dot<-parseTypeeJust(SignalArg(getattr"name"e)t)isArg::[String]->X.Element->[X.Element]isArgdirs=X.isNamed"arg">=>checkDirwherecheckDire=[e|getattr"direction"e`elem`dirs]parseProperty::X.Element->MaybePropertyparsePropertye=dot<-parseTypee(canRead,canWrite)<-casegetattr"access"eof""->Just(False,False)"read"->Just(True,False)"write"->Just(False,True)"readwrite"->Just(True,True)_->NothingJust(Property(getattr"name"e)tcanReadcanWrite)getattr::X.Name->X.Element->Stringgetattrnamee=maybe""Data.Text.unpack(X.attributeTextnamee)children::Monadm=>(X.Element->mb)->(X.Element->[X.Element])->X.Element->m[b]childrenfp=mapMf.concatMapp.X.elementChildrennewtypeXmlWritera=XmlWriter{runXmlWriter::Maybe(a,String)}instanceMonadXmlWriterwherereturna=XmlWriter$Just(a,"")m>>=f=XmlWriter$do(a,w)<-runXmlWriterm(b,w')<-runXmlWriter(fa)return(b,w++w')tell::String->XmlWriter()tells=XmlWriter(Just((),s))formatXML::Object->MaybeStringformatXMLobj=do(_,xml)<-runXmlWriter(writeRootobj)returnxmlwriteRoot::Object->XmlWriter()writeRootobj@(Objectpath__)=dotell"<!DOCTYPE node PUBLIC '-//freedesktop//DTD D-BUS Object Introspection 1.0//EN'"tell" 'http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd'>\n"writeObject(T.formatObjectPathpath)objwriteChild::T.ObjectPath->Object->XmlWriter()writeChildparentPathobj@(Objectpath__)=writewherepath'=T.formatObjectPathpathparent'=T.formatObjectPathparentPathrelpathM=ifparent'`isPrefixOf`path'thenJust$ifparent'=="/"thendrop1path'elsedrop(lengthparent'+1)path'elseNothingwrite=caserelpathMofJustrelpath->writeObjectrelpathobjNothing->XmlWriterNothingwriteObject::String->Object->XmlWriter()writeObjectpath(ObjectfullPathinterfaceschildren')=writeElement"node"[("name",path)]$domapM_writeInterfaceinterfacesmapM_(writeChildfullPath)children'writeInterface::Interface->XmlWriter()writeInterface(Interfacenamemethodssignalsproperties)=writeElement"interface"[("name",T.formatInterfaceNamename)]$domapM_writeMethodmethodsmapM_writeSignalsignalsmapM_writePropertypropertieswriteMethod::Method->XmlWriter()writeMethod(Methodnameargs)=writeElement"method"[("name",T.formatMemberNamename)]$domapM_writeMethodArgargswriteSignal::Signal->XmlWriter()writeSignal(Signalnameargs)=writeElement"signal"[("name",T.formatMemberNamename)]$domapM_writeSignalArgargsformatType::T.Type->XmlWriterStringformatTypet=dosig<-caseT.signature[t]ofJustx->returnxNothing->XmlWriterNothingreturn(T.formatSignaturesig)writeMethodArg::MethodArg->XmlWriter()writeMethodArg(MethodArgnametdir)=dotypeStr<-formatTypetletdirAttr=casedirofIn->"in"Out->"out"writeEmptyElement"arg"$[("name",name),("type",typeStr),("direction",dirAttr)]writeSignalArg::SignalArg->XmlWriter()writeSignalArg(SignalArgnamet)=dotypeStr<-formatTypetwriteEmptyElement"arg"$[("name",name),("type",typeStr)]writeProperty::Property->XmlWriter()writeProperty(PropertynametcanReadcanWrite)=dotypeStr<-formatTypetletreadS=ifcanReadthen"read"else""letwriteS=ifcanWritethen"write"else""writeEmptyElement"property"[("name",name),("type",typeStr),("access",readS++writeS)]attributeString::X.Name->X.Element->MaybeStringattributeStringnamee=fmapData.Text.unpack(X.attributeTextnamee)writeElement::String->[(String,String)]->XmlWriter()->XmlWriter()writeElementnameattrscontent=dotell"<"tellnamemapM_writeAttributeattrstell">"contenttell"</"tellnametell">"writeEmptyElement::String->[(String,String)]->XmlWriter()writeEmptyElementnameattrs=dotell"<"tellnamemapM_writeAttributeattrstell"/>"writeAttribute::(String,String)->XmlWriter()writeAttribute(name,content)=dotell" "tellnametell"='"tell(escapecontent)tell"'"escape::String->Stringescape=concatMap$\c->casecof'&'->"&amp;"'<'->"&lt;"'>'->"&gt;"'"'->"&quot;"'\''->"&apos;"_->[c]