setDt b dt e = e {elAttribs = elAttribs e ++ [Attr {attrKey
= makeQN (if b then "datatypeIRI" else "facet"), attrVal = showQU dt}]}
setLangTag :: Maybe LanguageTag -> Element -> Element
setLangTag ml e = case ml of
Just lt -> e {elAttribs = elAttribs e ++ [Attr {attrKey
= setQNPrefix "xml" (makeQN "lang"), attrVal = lt}]}
mwString :: String -> Element
mwString s = setName s nullElem
mwIRI iri = setIRI iri nullElem
mwNameIRI :: String -> IRI -> Element
mwNameIRI s iri = setName s $ mwIRI iri
mwText :: String -> Element
mwText s = setText s nullElem
mwSimpleIRI :: IRI -> Element
mwSimpleIRI s = setName iriK $ mwText $ showIRI s
makeElement :: String -> [Element] -> Element
makeElement s el = setContent el $ mwString s
make1 :: Bool -> String -> String -> (String -> IRI -> Element) -> IRI ->
[([Element], Element)] -> [Element]
make1 rl hdr shdr f iri = map (\ (a, b) -> makeElement hdr
$ a ++ (if rl then [f shdr iri, b] else [b, f shdr iri]))
make2 :: Bool -> String -> (a -> Element) -> a ->
[([Element], Element)] -> [Element]
make2 rl hdr f expr = map (\ (x, y) -> makeElement hdr
$ x ++ (if rl then [f expr, y] else [y, f expr]))
xmlEntity :: Entity -> Element
xmlEntity (Entity ty ent) = mwNameIRI (case ty of
ObjectProperty -> objectPropertyK
DataProperty -> dataPropertyK
AnnotationProperty -> annotationPropertyK
NamedIndividual -> namedIndividualK) ent
xmlLiteral :: Literal -> Element
xmlLiteral (Literal lf tu) =
let part = setName literalK $ mwText lf
Typed dt -> setDt True dt part
Untyped lang -> setLangTag lang $ setDt True (mkQName
xmlIndividual :: IRI -> Element
h = (not . null) np && head np == '_'
in mwNameIRI (if h then anonymousIndividualK
else namedIndividualK) iri
xmlFVPair :: (ConstrainingFacet, RestrictionValue) -> Element
xmlFVPair (cf, rv) = setDt False cf $ makeElement facetRestrictionK
xmlObjProp :: ObjectPropertyExpression -> Element
xmlObjProp ope = case ope of
ObjectProp op -> mwNameIRI objectPropertyK op
ObjectInverseOf i -> makeElement objectInverseOfK [xmlObjProp i]
xmlDataRange :: DataRange -> Element
xmlDataRange dr = case dr of
let dtelem = mwNameIRI datatypeK dt
in if null cfl then dtelem
else makeElement datatypeRestrictionK
$ dtelem : map xmlFVPair cfl
DataJunction jt drl -> makeElement (
IntersectionOf -> dataIntersectionOfK
DataComplementOf drn -> makeElement dataComplementOfK
DataOneOf ll -> makeElement dataOneOfK
xmlClassExpression :: ClassExpression -> Element
xmlClassExpression ce = case ce of
Expression c -> mwNameIRI classK c
ObjectJunction jt cel -> makeElement (
IntersectionOf -> objectIntersectionOfK
UnionOf -> objectUnionOfK)
$ map xmlClassExpression cel
ObjectComplementOf cex -> makeElement objectComplementOfK
ObjectOneOf il -> makeElement objectOneOfK
ObjectValuesFrom qt ope cex -> makeElement (
AllValuesFrom -> objectAllValuesFromK
SomeValuesFrom -> objectSomeValuesFromK)
[xmlObjProp ope, xmlClassExpression cex]
ObjectHasValue ope i -> makeElement objectHasValueK
[xmlObjProp ope, xmlIndividual i]
ObjectHasSelf ope -> makeElement objectHasSelfK [xmlObjProp ope]
ObjectCardinality (Cardinality ct i op mce) -> setInt i $ makeElement (
MinCardinality -> objectMinCardinalityK
MaxCardinality -> objectMaxCardinalityK
ExactCardinality -> objectExactCardinalityK)
Just cexp -> [xmlClassExpression cexp]
DataValuesFrom qt dp dr -> makeElement (
AllValuesFrom -> dataAllValuesFromK
SomeValuesFrom -> dataSomeValuesFromK)
[mwNameIRI dataPropertyK dp, xmlDataRange dr]
DataHasValue dp l -> makeElement dataHasValueK
[mwNameIRI dataPropertyK dp, xmlLiteral l]
DataCardinality (Cardinality ct i dp mdr) -> setInt i $ makeElement (
MinCardinality -> dataMinCardinalityK
MaxCardinality -> dataMaxCardinalityK
ExactCardinality -> dataExactCardinalityK)
$ mwNameIRI dataPropertyK dp :
Just dr -> [xmlDataRange dr]
xmlAnnotation :: Annotation -> Element
xmlAnnotation (Annotation al ap av) = makeElement annotationK
$ map xmlAnnotation al ++ [mwNameIRI annotationPropertyK ap,
AnnValue iri -> mwSimpleIRI iri
AnnValLit l -> xmlLiteral l]
xmlAnnotations :: Annotations -> [Element]
xmlAnnotations = map xmlAnnotation
xmlAL :: (a -> Element) -> AnnotatedList a -> [([Element], Element)]
xmlAL f al = let annos = map (xmlAnnotations . fst) al
other = map (\ (_, b) -> f b) al
xmlLFB :: Extended -> Maybe Relation -> ListFrameBit -> [Element]
xmlLFB ext mr lfb = case lfb of
let list = xmlAL mwSimpleIRI al
SimpleEntity (Entity _ ap) = ext
in case fromMaybe (error "expected domain, range, subproperty") mr of
let list2 = xmlAL (mwNameIRI annotationPropertyK) al
in make1 True subAnnotationPropertyOfK annotationPropertyK
DRRelation ADomain -> make1 True subAnnotationPropertyOfK
annotationPropertyK mwNameIRI ap list
DRRelation ARange -> make1 True subAnnotationPropertyOfK
annotationPropertyK mwNameIRI ap list
_ -> error "bad annotation bit"
let list = xmlAL xmlClassExpression al in case ext of
Misc anno -> [makeElement (case fromMaybe
(error "expected equiv--, disjoint--, class") mr of
EDRelation Equivalent -> equivalentClassesK
EDRelation Disjoint -> disjointClassesK
_ -> error "bad equiv or disjoint classes bit"
) $ xmlAnnotations anno ++ map snd list]
ClassEntity c -> make2 True (case fromMaybe
(error "expected equiv--, disjoint--, sub-- class") mr of
EDRelation Equivalent -> equivalentClassesK
EDRelation Disjoint -> disjointClassesK
_ -> error "bad equiv, disjoint, subClass bit")
xmlClassExpression c list
ObjectEntity op -> make2 True (case fromMaybe
(error "expected domain, range") mr of
DRRelation ADomain -> objectPropertyDomainK
DRRelation ARange -> objectPropertyRangeK
_ -> "bad object domain or range bit") xmlObjProp op list
SimpleEntity (Entity ty ent) -> case ty of
DataProperty -> make1 True dataPropertyDomainK dataPropertyK
NamedIndividual -> make2 False classAssertionK
_ -> error "bad expression bit"
let list = xmlAL xmlObjProp al in case ext of
Misc anno -> [makeElement (case fromMaybe
(error "expected equiv--, disjoint-- obj prop") mr of
EDRelation Equivalent -> equivalentObjectPropertiesK
EDRelation Disjoint -> disjointObjectPropertiesK
_ -> error "bad object bit (equiv, disjoint)"
) $ xmlAnnotations anno ++ map snd list]
ObjectEntity o -> make2 True (case fromMaybe
(error "expected sub, Inverse, equiv, disjoint op") mr of
SubPropertyOf -> subObjectPropertyOfK
InverseOf -> inverseObjectPropertiesK
EDRelation Equivalent -> equivalentObjectPropertiesK
EDRelation Disjoint -> disjointObjectPropertiesK
_ -> error "bad object bit (subpropertyof, inverseof)"
_ -> error "bad object bit"
let list = xmlAL (mwNameIRI dataPropertyK) al in case ext of
Misc anno -> [makeElement (case fromMaybe
(error "expected equiv--, disjoint-- data prop") mr of
EDRelation Equivalent -> equivalentDataPropertiesK
EDRelation Disjoint -> disjointDataPropertiesK
_ -> error "bad data bit"
) $ xmlAnnotations anno ++ map snd list]
SimpleEntity (Entity _ ent) -> make1 True (case fromMaybe
(error "expected sub, equiv or disjoint data") mr of
SubPropertyOf -> subDataPropertyOfK
EDRelation Equivalent -> equivalentDataPropertiesK
EDRelation Disjoint -> disjointDataPropertiesK
_ -> error "bad data bit"
) dataPropertyK mwNameIRI ent list
_ -> error "bad data bit"
IndividualSameOrDifferent al ->
let list = xmlAL xmlIndividual al in case ext of
Misc anno -> [makeElement (case fromMaybe
(error "expected same--, different-- individuals") mr of
SDRelation Same -> sameIndividualK
SDRelation Different -> differentIndividualsK
_ -> error "bad individual bit (s or d)"
) $ xmlAnnotations anno ++ map snd list]
SimpleEntity (Entity _ i) -> make2 True (case fromMaybe
(error "expected same--, different-- individuals") mr of
SDRelation Same -> sameIndividualK
SDRelation Different -> differentIndividualsK
_ -> error "bad individual bit (s or d)"
_ -> error "bad individual same or different"
ObjectCharacteristics al ->
let ObjectEntity op = ext
annos = map (xmlAnnotations . fst) al
list = zip annos (map snd al)
in map (\ (x, y) -> makeElement (case y of
Functional -> functionalObjectPropertyK
InverseFunctional -> inverseFunctionalObjectPropertyK
Reflexive -> reflexiveObjectPropertyK
Irreflexive -> irreflexiveObjectPropertyK
Symmetric -> symmetricObjectPropertyK
Asymmetric -> asymmetricObjectPropertyK
Transitive -> transitiveObjectPropertyK
Antisymmetric -> antisymmetricObjectPropertyK
) $ x ++ [xmlObjProp op]) list
let SimpleEntity (Entity DataProperty dp) = ext
list = xmlAL xmlDataRange al
in make1 True dataPropertyRangeK dataPropertyK mwNameIRI dp list
let SimpleEntity (Entity NamedIndividual i) = ext
annos = map (xmlAnnotations . fst) al
list = zip annos (map snd al)
in map (\ (x, f) -> case f of
ObjectPropertyFact pn op ind ->
Positive -> objectPropertyAssertionK
Negative -> negativeObjectPropertyAssertionK
++ map xmlIndividual [i, ind]
DataPropertyFact pn dp lit ->
Positive -> dataPropertyAssertionK
Negative -> negativeDataPropertyAssertionK
) $ x ++ [mwNameIRI dataPropertyK dp] ++
[xmlIndividual i] ++ [xmlLiteral lit]
xmlAFB :: Extended -> Annotations -> AnnFrameBit -> [Element]
xmlAFB ext anno afb = case afb of
AnnotationFrameBit -> case ext of
let Entity ty iri = ent in case ty of
AnnotationProperty -> map (\ (Annotation as s v) ->
makeElement annotationAssertionK $
++ [mwNameIRI annotationPropertyK iri]
++ [mwSimpleIRI s, case v of
AnnValue avalue -> mwSimpleIRI avalue
AnnValLit l -> xmlLiteral l]) anno
_ -> [makeElement declarationK
$ xmlAnnotations anno ++ [xmlEntity ent]]
let [Annotation _ ap _] = anno
in [makeElement declarationK
$ xmlAnnotations as ++ [mwNameIRI annotationPropertyK ap]]
_ -> error "bad ann frane bit"
let SimpleEntity (Entity _ dp) = ext
in [makeElement functionalDataPropertyK
$ xmlAnnotations anno ++ [mwNameIRI dataPropertyK dp]]
let SimpleEntity (Entity _ dt) = ext
in [makeElement datatypeDefinitionK
$ xmlAnnotations anno ++ [mwNameIRI datatypeK dt,
ClassDisjointUnion cel ->
in [makeElement disjointUnionK
$ xmlAnnotations anno ++ map xmlClassExpression (c : cel)]
$ xmlAnnotations anno ++ [xmlClassExpression c]
++ map xmlObjProp op ++ map (mwNameIRI dataPropertyK) dp]
ObjectSubPropertyChain opl ->
let ObjectEntity op = ext
xmlop = map xmlObjProp opl
in [makeElement subObjectPropertyOfK
[makeElement objectPropertyChainK xmlop, xmlObjProp op]]
xmlFrameBit :: Extended -> FrameBit -> [Element]
xmlFrameBit ext fb = case fb of
ListFrameBit mr lfb -> xmlLFB ext mr lfb
AnnFrameBit anno afb -> xmlAFB ext anno afb
xmlAxioms :: Axiom -> [Element]
xmlAxioms (PlainAxiom ext fb) = xmlFrameBit ext fb
xmlFrames :: Frame -> [Element]
xmlFrames (Frame ext fbl) = concatMap (xmlFrameBit ext) fbl
xmlImport :: ImportIRI -> Element
xmlImport i = setName importK $ mwText $ showIRI i
setPref :: String -> Element -> Element
setPref s e = e {elAttribs = Attr {attrKey = makeQN "name"
, attrVal = s} : elAttribs e}
set1Map :: (String, String) -> Element
set1Map (s, iri) = setPref s $ mwIRI $ setFull $ splitIRI "" $ mkQName iri
xmlPrefixes :: PrefixMap -> [Element]
xmlPrefixes pm = map (setName prefixK . set1Map) $
Map.toList pm
setXMLNS :: Element -> Element
setXMLNS e = e {elAttribs = Attr {attrKey = makeQN "xmlns", attrVal =
setOntIRI :: OntologyIRI -> Element -> Element
if elem iri [nullQName, dummyQName] then e
else e {elAttribs = Attr {attrKey = makeQN "ontologyIRI",
attrVal = showQU iri} : elAttribs e}
setBase :: String -> Element -> Element
setBase s e = e {elAttribs = Attr {attrKey = nullQN {qName = "base",
qPrefix = Just "xml"}, attrVal = s} : elAttribs e}
xmlOntologyDoc :: OntologyDocument -> Element
pd = prefixDeclaration od
emptyPref = fromMaybe (showIRI dummyQName) $
Map.lookup "" pd
in setBase emptyPref $ setXMLNS $ setOntIRI (name ont)
$ makeElement "Ontology" $ xmlPrefixes pd
++ map xmlImport (imports ont)
++ concatMap xmlFrames (ontFrames ont)
++ concatMap xmlAnnotations (ann ont)