moduleText.XML.HaXml.Schema.Parse(moduleText.XML.HaXml.Schema.Parse)whereimportData.Char(isSpace)importData.List(isPrefixOf)importData.Monoid(Monoid(mappend))-- import Text.ParserCombinators.PolyimportText.Parse-- for String parsersimportText.XML.HaXml.Types(Name,QName(..),Namespace(..),Attribute(..),Content(..),Element(..),info)importText.XML.HaXml.NamespacesimportText.XML.HaXml.Verbatimhiding(qname)importText.XML.HaXml.PosnimportText.XML.HaXml.Schema.XSDTypeModelasXSDimportText.XML.HaXml.XmlContent.Parser(text)-- | Lift boolean 'or' over predicates.(|||)::(a->Bool)->(a->Bool)->(a->Bool)p|||q=\v->pv||qv-- | Qualify an ordinary name with the XSD namespace.xsd::Name->QNamexsdname=QNNamespace{nsPrefix="xsd",nsURI="http://www.w3.org/2001/XMLSchema"}name-- | Predicate for comparing against an XSD-qualified name. (Also accepts-- unqualified names, but this is probably a bit too lax. Doing it right-- would require checking to see whether the current schema module's default-- namespace is XSD or not.)xsdTag::String->ContentPosn->BoolxsdTagtag(CElem(Elemqn__)_)=qn==xsdtag||qn==(Ntag)xsdTag__=False-- | We need a Parser monad for reading from a sequence of generic XML-- Contents into specific datatypes that model the structure of XSD-- descriptions. This is a specialisation of the polyparse combinators,-- fixing the input token type.typeXsdParsera=Parser(ContentPosn)a-- | Get the next content element, checking that it matches some criterion-- given by the predicate.-- (Skips over comments and whitespace, rejects text and refs.-- Also returns position of element.)-- The list of strings argument is for error reporting - it usually-- represents a list of expected tags.posnElementWith::(ContentPosn->Bool)->[String]->XsdParser(Posn,ElementPosn)posnElementWithmatchtags=do{c<-next`adjustErr`(++" when expecting "++formattedtags);casecofCElemepos|matchc->return(pos,e)CElem(Elemt__)pos|otherwise->fail("Found a <"++printableNamet++">, but expected "++formattedtags++"\nat "++showpos)CStringbspos-- ignore blank space|notb&&allisSpaces->posnElementWithmatchtags|otherwise->fail("Found text content, but expected "++formattedtags++"\ntext is: "++s++"\nat "++showpos)CRefrpos->fail("Found reference, but expected "++formattedtags++"\nreference is: "++verbatimr++"\nat "++showpos)CMisc__->posnElementWithmatchtags-- skip comments, PIs, etc.}whereformatted[t]="a <"++t++">"formattedtgs="one of"++concatMap(\t->" <"++t++">")tgs-- | Get the next content element, checking that it has the required tag-- belonging to the XSD namespace.xsdElement::Name->XsdParser(ElementPosn)xsdElementn=fmapsnd(posnElementWith(xsdTagn)["xsd:"++n])-- | Get the next content element, whatever it is.anyElement::XsdParser(ElementPosn)anyElement=fmapsnd(posnElementWith(constTrue)["any element"])-- | Grab and parse any and all children of the next element.allChildren::XsdParsera->XsdParseraallChildrenp=doe<-anyElementinteriorWith(constTrue)pe-- | Run an XsdParser on the child contents of the given element (i.e. not-- in the current monadic content sequence), filtering the children-- before parsing, and checking that the contents are exhausted, before-- returning the calculated value within the current parser context.interiorWith::(ContentPosn->Bool)->XsdParsera->ElementPosn->XsdParserainteriorWithkeep(Pp)(Eleme_cs)=P$\inp->tidyinp$casep(filterkeepcs)ofCommittedr->rf@(Failure__)->fs@(Success[]_)->sSuccessds@(d:_)a|allonlyMiscds->Success[]a|otherwise->Committed$Failureds("Too many elements inside <"++printableNamee++"> at\n"++show(infod)++"\n\n"++"Found excess: "++verbatim(take5ds))whereonlyMisc(CMisc__)=TrueonlyMisc(CStringFalses_)|allisSpaces=TrueonlyMisc_=False-- | Check for the presence (and value) of an attribute in the given element.-- Absence results in failure.attribute::QName->TextParsera->ElementPosn->XsdParseraattributeqn(Pp)(Elemnas_)=P$\inp->caselookupqnasofNothing->Failureinp$"attribute "++printableNameqn++" not present in <"++printableNamen++">"Justatv->tidyinp$casep(showatv)ofCommittedr->rFailurezmsg->Failurez$"Attribute parsing failure: "++printableNameqn++"=\""++showatv++"\": "++msgSuccess[]v->Success[]vSuccessxs_->Committed$Failurexs$"Attribute parsing excess text: "++printableNameqn++"=\""++showatv++"\":\n Excess is: "++xs-- | Grab any attributes that declare a locally-used prefix for a-- specific namespace.namespaceAttrs::ElementPosn->XsdParser[Namespace]namespaceAttrs(Elem_as_)=return.mapmkNamespace.filter(matchNamespace"xmlns")$aswheredeQN(QN_n)=nmkNamespace(attname,attval)=Namespace{nsPrefix=deQNattname,nsURI=verbatimattval}-- | Predicate for whether an attribute belongs to a given namespace.matchNamespace::String->Attribute->BoolmatchNamespacen(Nm,_)=False-- (n++":") `isPrefixOf` mmatchNamespacen(QNns_,_)=n==nsPrefixns-- | Tidy up the parsing context.tidy::t->Resultxa->Resulttatidyinp(Committedr)=tidyinprtidyinp(Failure_m)=Failureinpmtidyinp(Success_v)=Successinpv-- | Given a URI for a targetNamespace, and a list of Namespaces, tell-- me the prefix corresponding to the targetNamespace.targetPrefix::MaybeTargetNamespace->[Namespace]->MaybeStringtargetPrefixNothing_=NothingtargetPrefix(Justuri)nss=fmapnsPrefix$lookupBy((==uri).nsURI)nss-- | An auxiliary you might expect to find in Data.ListlookupBy::(a->Bool)->[a]->MaybealookupByp[]=NothinglookupByp(y:ys)|py=Justy|otherwise=lookupBypys-- | Turn a qualified attribute value (two strings) into a qualified name-- (QName), but excluding the case where the namespace prefix corresponds-- to the targetNamespace of the current schema document.qual::MaybeTargetNamespace->[Namespace]->String->String->QNamequaltnnssprenm=casetargetPrefixtnnssofNothing->QNthisNSnmJustp|p/=pre->QNthisNSnm|otherwise->NnmwherethisNS=Namespace{nsPrefix=pre,nsURI=maybe""nsURI$lookupBy((==pre).nsPrefix)nss}-- Now for the real parsers.-- | Parse a Schema declarationschema=doe<-xsdElement"schema"commit$dotn<-optional(attribute(N"targetNamespace")urie)nss<-namespaceAttrsereturnSchema`apply`(attribute(N"elementFormDefault")qforme`onFail`returnUnqualified)`apply`(attribute(N"attributeFormDefault")qforme`onFail`returnUnqualified)`apply`optional(attribute(xsd"finalDefault")finale)`apply`optional(attribute(xsd"blockDefault")blocke)`apply`returntn`apply`optional(attribute(N"version")stringe)`apply`returnnss`apply`interiorWith(constTrue)(many(schemaItem(qualtnnss)))e-- | Parse a (possibly missing) <xsd:annotation> element.annotation::XsdParserAnnotationannotation=dodefiniteAnnotation`onFail`return(NoAnnotation"missing")-- | Parse a definitely-occurring <xsd:annotation> element.definiteAnnotation::XsdParserAnnotationdefiniteAnnotation=doe<-xsdElement"annotation"(fmapDocumentation$interiorWith(xsdTag"documentation")(allChildrentext)e)`onFail`(fmapAppInfo$interiorWith(xsdTag"documentation")(allChildrentext)e)`onFail`(return(NoAnnotation"failed to parse"))-- | Parse a FormDefault attribute.qform::TextParserQFormqform=dow<-wordcasewof"qualified"->returnQualified"unqualified"->returnUnqualified_->failBad"Expected \"qualified\" or \"unqualified\""-- | Parse a Final or Block attribute.final::TextParserFinalfinal=dow<-wordcasewof"restriction"->returnNoRestriction"extension"->returnNoExtension"#all"->returnAllFinal_->failBad$"Expected \"restriction\" or \"extension\""++" or \"#all\""block::TextParserBlockblock=final-- | Parse a schema item (just under the toplevel <xsd:schema>)schemaItem::(String->String->QName)->XsdParserSchemaItemschemaItemqual=oneOf'[("xsd:include",include),("xsd:import",import_),("xsd:redefine",(redefinequal)),("xsd:annotation",fmapAnnotationdefiniteAnnotation)--,("xsd:simpleType",fmapSimple(simpleTypequal)),("xsd:complexType",fmapComplex(complexTypequal)),("xsd:element",fmapSchemaElement(elementDeclqual)),("xsd:attribute",fmapSchemaAttribute(attributeDeclqual)),("xsd:attributeGroup",fmapAttributeGroup(attributeGroupqual)),("xsd:group",fmapSchemaGroup(group_qual))-- , ("xsd:notation", notation)]-- | Parse an <xsd:include>.include::XsdParserSchemaIteminclude=doe<-xsdElement"include"commit$returnInclude`apply`attribute(N"schemaLocation")urie`apply`interiorWith(xsdTag"annotation")annotatione-- | Parse an <xsd:import>.import_::XsdParserSchemaItemimport_=doe<-xsdElement"import"commit$returnImport`apply`attribute(N"namespace")urie`apply`attribute(N"schemaLocation")urie`apply`interiorWith(xsdTag"annotation")annotatione-- | Parse a <xsd:redefine>.redefine::(String->String->QName)->XsdParserSchemaItemredefineq=doe<-xsdElement"redefine"commit$returnRedefine`apply`attribute(N"schemaLocation")urie`apply`interiorWith(constTrue)(many(schemaItemq))e-- | Parse a <xsd:simpleType> decl.simpleType::(String->String->QName)->XsdParserSimpleTypesimpleTypeq=doe<-xsdElement"simpleType"n<-optional(attribute(N"name")namee)f<-optional(attribute(N"final")finale)a<-interiorWith(xsdTag"annotation")annotationecommit$interiorWith(not.xsdTag"annotation")(simpleItemnfa)ewheresimpleItemnfa=doe<-xsdElement"restriction"commit$doa1<-interiorWith(xsdTag"annotation")annotationeb<-optional(attribute(N"base")(qnameq)e)r<-interiorWith(not.xsdTag"annotation")(restrictTypea1b`onFail`restriction1a1b)ereturn(Restrictedanfr)`onFail`doe<-xsdElement"list"commit$doa1<-interiorWith(xsdTag"annotation")annotationet<-attribute(N"itemType")(fmapRight(qnameq))e`onFail`interiorWith(xsdTag"simpleType")(fmapLeft(simpleTypeq))e`adjustErr`(("Expected attribute 'itemType' or element <simpleType>\n"++" inside <list> decl.\n")++)return(ListOf(a`mappend`a1)nft)`onFail`doe<-xsdElement"union"commit$doa1<-interiorWith(xsdTag"annotation")annotationets<-interiorWith(xsdTag"simpleType")(many(simpleTypeq))ems<-attribute(N"memberTypes")(many(qnameq))e`onFail`return[]return(UnionOf(a`mappend`a1)nftsms)`adjustErr`("xsd:simpleType does not contain a restriction, list, or union\n"++)restriction1ab=return(RestrictSim1ab)`apply`(returnRestriction1`apply`particleq)restrictTypeab=return(RestrictTypeab)`apply`(optional(simpleTypeq))`apply`manyaFacetaFacet::XsdParserFacetaFacet=foldronFail(fail"Could not recognise simpleType Facet")(zipWithfacet["minInclusive","minExclusive","maxInclusive","maxExclusive","totalDigits","fractionDigits","length","minLength","maxLength","enumeration","whiteSpace","pattern"][OrderedBoundsMinIncl,OrderedBoundsMinExcl,OrderedBoundsMaxIncl,OrderedBoundsMaxExcl,OrderedNumericTotalDigits,OrderedNumericFractionDigits,UnorderedLength,UnorderedMinLength,UnorderedMaxLength,UnorderedEnumeration,UnorderedWhitespace,UnorderedPattern])facet::String->FacetType->XsdParserFacetfacetst=doe<-xsdElementsv<-attribute(N"value")stringef<-attribute(N"fixed")boole`onFail`returnFalse-- XXX check thisa<-interiorWith(constTrue)annotationereturn(Facettavf)-- | Parse a <xsd:complexType> decl.complexType::(String->String->QName)->XsdParserComplexTypecomplexTypeq=doe<-xsdElement"complexType"commit$returnComplexType`apply`interiorWith(xsdTag"annotation")annotatione`apply`optional(attribute(N"name")stringe)`apply`(attribute(N"abstract")boole`onFail`returnFalse)`apply`optional(attribute(N"final")finale)`apply`optional(attribute(N"block")blocke)`apply`(attribute(N"mixed")boole`onFail`returnFalse)`apply`interiorWith(not.xsdTag"annotation")(complexItemq)e-- | Parse the alternative contents of a <xsd:complexType> decl.complexItem::(String->String->QName)->XsdParserComplexItemcomplexItemq=(doe<-xsdElement"simpleContent"commit$returnSimpleContent`apply`interiorWith(xsdTag"annotation")annotatione`apply`interiorWith(not.xsdTag"annotation")stuffe)`onFail`(doe<-xsdElement"complexContent"commit$returnComplexContent`apply`interiorWith(xsdTag"annotation")annotatione`apply`(attribute(N"mixed")boole`onFail`returnFalse)`apply`interiorWith(not.xsdTag"annotation")stuffe)`onFail`(dofmapThisType$particleAttrsq)wherestuff::XsdParser(EitherRestriction1Extension)stuff=(doe<-xsdElement"restriction"commit$fmapLeft$returnRestriction1`apply`particleq)`onFail`(doe<-xsdElement"extension"commit$fmapRight$returnExtension`apply`interiorWith(xsdTag"annotation")annotatione`apply`attribute(N"base")(qnameq)e`apply`interiorWith(not.xsdTag"annotation")(particleAttrsq)e)-- | Parse a particle decl.particle::(String->String->QName)->XsdParserParticleparticleq=optional(fmapLeft(choiceOrSeqq)`onFail`fmapRight(group_q))-- | Parse a particle decl with optional attributes.particleAttrs::(String->String->QName)->XsdParserParticleAttrsparticleAttrsq=returnPA`apply`particleq`apply`many(fmapLeft(attributeDeclq)`onFail`fmapRight(attributeGroupq))`apply`optionalanyAttr-- | Parse an <xsd:all>, <xsd:choice>, or <xsd:sequence> decl.choiceOrSeq::(String->String->QName)->XsdParserChoiceOrSeqchoiceOrSeqq=doe<-xsdElement"all"commit$returnAll`apply`interiorWith(xsdTag"annotation")annotatione`apply`interiorWith(not.xsdTag"annotation")(many(elementDeclq))e`onFail`doe<-xsdElement"choice"commit$returnChoice`apply`interiorWith(xsdTag"annotation")annotatione`apply`occurse`apply`interiorWith(not.xsdTag"annotation")(many(elementEtcq))e`onFail`doe<-xsdElement"sequence"commit$returnSequence`apply`interiorWith(xsdTag"annotation")annotatione`apply`occurse`apply`interiorWith(not.xsdTag"annotation")(many(elementEtcq))e-- | Parse a <xsd:group> decl.group_::(String->String->QName)->XsdParserGroupgroup_q=doe<-xsdElement"group"commit$returnGroup`apply`interiorWith(xsdTag"annotation")annotatione`apply`(fmapLeft(attribute(N"name")stringe)`onFail`fmapRight(attribute(N"ref")(qnameq)e))`apply`occurse`apply`interiorWith(not.xsdTag"annotation")(optional(choiceOrSeqq))e-- | Parse an <xsd:element>, <xsd:group>, <xsd:all>, <xsd:choice>,-- <xsd:sequence> or <xsd:any>.elementEtc::(String->String->QName)->XsdParserElementEtcelementEtcq=fmapHasElement(elementDeclq)`onFail`fmapHasGroup(group_q)`onFail`fmapHasCS(choiceOrSeqq)`onFail`fmapHasAnyany_-- | Parse an <xsd:any>.any_::XsdParserAnyany_=doe<-xsdElement"any"commit$returnAny`apply`interiorWith(xsdTag"annotation")annotatione`apply`(attribute(N"namespace")urie`onFail`return"##any")`apply`(attribute(N"processContents")processContentse`onFail`returnStrict)`apply`occurse-- | Parse an <xsd:anyAttribute>.anyAttr::XsdParserAnyAttranyAttr=doe<-xsdElement"anyAttribute"commit$returnAnyAttr`apply`interiorWith(xsdTag"annotation")annotatione`apply`(attribute(N"namespace")urie`onFail`return"##any")`apply`(attribute(N"processContents")processContentse`onFail`returnStrict)-- | Parse an <xsd:attributegroup>.attributeGroup::(String->String->QName)->XsdParserAttrGroupattributeGroupq=doe<-xsdElement"attributeGroup"commit$returnAttrGroup`apply`interiorWith(xsdTag"annotation")annotatione`apply`(fmapLeft(attribute(N"name")stringe)`onFail`fmapRight(attribute(N"ref")(qnameq)e))`apply`interiorWith(not.xsdTag"annotation")(manystuff)ewherestuff=fmapLeft(attributeDeclq)`onFail`fmapRight(attributeGroupq)-- | Parse an <xsd:element> decl.elementDecl::(String->String->QName)->XsdParserElementDeclelementDeclq=doe<-xsdElement"element"commit$returnElementDecl`apply`interiorWith(xsdTag"annotation")annotatione`apply`(fmapLeft(nameAndTypeqe)`onFail`fmapRight(attribute(N"ref")(qnameq)e))`apply`occurse`apply`(attribute(N"nillable")boole`onFail`returnFalse)`apply`optional(attribute(N"substitutionGroup")(qnameq)e)`apply`(attribute(N"abstract")boole`onFail`returnFalse)`apply`optional(attribute(xsd"final")finale)`apply`optional(attribute(xsd"block")blocke)`apply`(attribute(xsd"form")qforme`onFail`returnUnqualified)`apply`interiorWith(xsdTag"simpleType"|||xsdTag"complexType")(optional(fmapLeft(simpleTypeq)`onFail`fmapRight(complexTypeq)))e`apply`interiorWith(xsdTag"unique"|||xsdTag"key"|||xsdTag"keyRef")(many(uniqueKeyOrKeyRefq))e-- | Parse name and type attributes.nameAndType::(String->String->QName)->ElementPosn->XsdParserNameAndTypenameAndTypeqe=returnNT`apply`attribute(N"name")stringe`apply`optional(attribute(N"type")(qnameq)e)-- | Parse an <xsd:attribute> decl.attributeDecl::(String->String->QName)->XsdParserAttributeDeclattributeDeclq=doe<-xsdElement"attribute"commit$returnAttributeDecl`apply`interiorWith(xsdTag"annotation")annotatione`apply`(fmapLeft(nameAndTypeqe)`onFail`fmapRight(attribute(N"ref")(qnameq)e))`apply`(attribute(N"use")usee`onFail`returnOptional)`apply`(optional(attribute(N"default")(fmapLeftstring)e`onFail`attribute(N"fixed")(fmapRightstring)e))`apply`(attribute(xsd"form")qforme`onFail`returnUnqualified)`apply`interiorWith(xsdTag"simpleType")(optional(simpleTypeq))e-- | Parse an occurrence range from attributes of given element.occurs::ElementPosn->XsdParserOccursoccurse=returnOccurs`apply`(optional$attribute(N"minOccurs")parseDece)`apply`(optional$attribute(N"maxOccurs")maxDece)wheremaxDec=parseDec`onFail`doisWord"unbounded";returnmaxBound-- | Parse a <xsd:unique>, <xsd:key>, or <xsd:keyref>.uniqueKeyOrKeyRef::(String->String->QName)->XsdParserUniqueKeyOrKeyRefuniqueKeyOrKeyRefq=fmapUunique`onFail`fmapKkey`onFail`fmapKR(keyRefq)-- | Parse a <xsd:unique>.unique::XsdParserUniqueunique=doe<-xsdElement"unique"commit$returnUnique`apply`interiorWith(xsdTag"annotation")annotatione`apply`attribute(N"name")stringe`apply`interiorWith(xsdTag"selector")selectore`apply`interiorWith(xsdTag"field")(many1field_)e-- | Parse a <xsd:key>.key::XsdParserKeykey=doe<-xsdElement"key"commit$returnKey`apply`interiorWith(xsdTag"annotation")annotatione`apply`attribute(N"name")stringe`apply`interiorWith(xsdTag"selector")selectore`apply`interiorWith(xsdTag"field")(many1field_)e-- | Parse a <xsd:keyref>.keyRef::(String->String->QName)->XsdParserKeyRefkeyRefq=doe<-xsdElement"keyref"commit$returnKeyRef`apply`interiorWith(xsdTag"annotation")annotatione`apply`attribute(N"name")stringe`apply`attribute(N"refer")(qnameq)e`apply`interiorWith(xsdTag"selector")selectore`apply`interiorWith(xsdTag"field")(many1field_)e-- | Parse a <xsd:selector>.selector::XsdParserSelectorselector=doe<-xsdElement"selector"commit$returnSelector`apply`interiorWith(xsdTag"annotation")annotatione`apply`attribute(N"xpath")stringe-- | Parse a <xsd:field>.field_::XsdParserFieldfield_=doe<-xsdElement"field"commit$returnField`apply`interiorWith(xsdTag"annotation")annotatione`apply`attribute(N"xpath")stringe-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ---- | Text parser for a URI (very simple, non-validating, probably incorrect).uri::TextParserStringuri=string-- | Text parser for an arbitrary string consisting of possibly multiple tokens.string::TextParserStringstring=fmapconcat$manyword-- | Parse a textual boolean, i.e. "true", "false", "0", or "1"bool::TextParserBoolbool=dow<-wordcasewof"true"->returnTrue"false"->returnFalse"0"->returnTrue"1"->returnFalse_->fail"could not parse boolean value"-- | Parse a "use" attribute value, i.e. "required", "optional", or "prohibited"use::TextParserUseuse=dow<-wordcasewof"required"->returnRequired"optional"->returnOptional"prohibited"->returnProhibited_->fail"could not parse \"use\" attribute value"-- | Parse a "processContents" attribute, i.e. "skip", "lax", or "strict".processContents::TextParserProcessContentsprocessContents=dow<-wordcasewof"skip"->returnSkip"lax"->returnLax"strict"->returnStrict_->fail"could not parse \"processContents\" attribute value"-- | Parse an attribute value that should be a QName.qname::(String->String->QName)->TextParserQNameqnameq=doa<-word(do":"<-wordb<-wordreturn(qab)`onFail`docs<-manynextreturn(N(a++cs)))-- | Parse an attribute value that should be a simple Name.name::TextParserNamename=word