{- |

Module : $Header$

Copyright : (c) Felix Gabriel Mance

License : GPLv2 or higher, see LICENSE.txt

Maintainer : f.mance@jacobs-university.de

Stability : provisional

Portability : portable

Conversion from Manchester Syntax to XML Syntax

-}

module OWL2.XMLConversion where

import Common.AS_Annotation (Named, sentence)

import OWL2.AS

import OWL2.MS

import OWL2.Sign

import OWL2.XML

import OWL2.XMLKeywords

import Text.XML.Light

import Data.Maybe

import qualified Data.Set as Set

import qualified Data.Map as Map

-- | prints the IRI with a colon separating the prefix and the local part

showIRI :: IRI -> String

showIRI (QN pre local ty _ _) = case ty of

NodeID -> local

_ -> pre ++ ":" ++ local

nullQN :: Text.XML.Light.QName

nullQN = QName "" Nothing Nothing

nullElem :: Element

nullElem = Element nullQN [] [] Nothing

makeQN :: String -> Text.XML.Light.QName

makeQN s = nullQN {qName = s}

-- | sets the content of an element to a list of given elements

setContent :: [Element] -> Element -> Element

setContent cl e = e {elContent = map Elem cl}

-- | sets the content of an element to a given string

setText :: String -> Element -> Element

setText s e = e {elContent = [Text CData {cdVerbatim = CDataText,

cdData = s, cdLine = Nothing}]}

setQNPrefix :: String -> Text.XML.Light.QName -> Text.XML.Light.QName

setQNPrefix s qn = qn {qPrefix = Just s}

{- | sets the name of an element to a given string

and the namespace to <http://www.w3.org/2002/07/owl#> -}

setName :: String -> Element -> Element

setName s e = e {elName = nullQN {qName = s,

qURI = Just "http://www.w3.org/2002/07/owl#"} }

{- | sets the attribute key to one of IRI, abbreviatedIRI or nodeID

and the attribute value to the actual content of the IRI -}

setIRI :: IRI -> Element -> Element

setIRI iri e =

let fan = iriType iri

ty

| fan == Full = "IRI"

| fan == Abbreviated = "abbreviatedIRI"

| otherwise = "nodeID"

in e {elAttribs = [Attr {attrKey = makeQN ty,

attrVal = showIRI $ setReservedPrefix iri}]}

mwIRI :: IRI -> Element

mwIRI iri = setIRI iri nullElem

-- | makes an element with the string as name and the IRI as content

mwNameIRI :: String -> IRI -> Element

mwNameIRI s iri = setName s $ mwIRI iri

-- | makes a new element with the given string as name

mwString :: String -> Element

mwString s = setName s nullElem

-- | makes a new element with the string as name and an element as content

makeElementWith1 :: String -> Element -> Element

makeElementWith1 s e = setContent [e] $ mwString s

{- | makes a new element with the string as name and the list of elements

as content -}

makeElement :: String -> [Element] -> Element

makeElement s el = setContent el $ mwString s

mwText :: String -> Element

mwText s = setText s nullElem

-- | makes a new element with the IRI as the text content

mwSimpleIRI :: IRI -> Element

mwSimpleIRI s = setName (if iriType s /= Abbreviated then "IRI"

else "AbbreviatedIRI") $ mwText $ showIRI

$ setReservedPrefix s

{- | generates a list of elements, all with the first string as name,

and each with the content in this order: first, the list of elements

in the given pair (usually annotations) and second, the result of the

application of the function (given as fourth argument) on the second string

and the given IRI -}

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]))

-- almost the same, just that the function takes only one argument

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]))

-- | sets the cardinality

setInt :: Int -> Element -> Element

setInt i e = e {elAttribs = [Attr {attrKey = makeQN "cardinality",

attrVal = show i}]}

-- | sets either a literal datatype or a facet

setDt :: Bool -> IRI -> Element -> Element

setDt b dt e = e {elAttribs = elAttribs e ++ [Attr {attrKey

= makeQN (if b then "datatypeIRI" else "facet"),

attrVal = showIRI $ setReservedPrefix dt}]}

setLangTag :: Maybe LanguageTag -> Element -> Element

setLangTag ml e = case ml of

Nothing -> e

Just lt -> e {elAttribs = elAttribs e ++ [Attr {attrKey

= setQNPrefix "xml" (makeQN "lang"), attrVal = lt}]}

xmlEntity :: Entity -> Element

xmlEntity (Entity ty ent) = mwNameIRI (case ty of

Class -> classK

Datatype -> datatypeK

ObjectProperty -> objectPropertyK

DataProperty -> dataPropertyK

AnnotationProperty -> annotationPropertyK

NamedIndividual -> namedIndividualK) ent

xmlLiteral :: Literal -> Element

xmlLiteral l = case l of

Literal lf tu ->

let part = setName literalK $ mwText lf

in case tu of

Typed dt -> setDt True dt part

Untyped lang -> setLangTag lang $ setDt True (splitIRI $ mkQName

"http://www.w3.org/1999/02/22-rdf-syntax-ns#PlainLiteral")

part

NumberLit f -> setDt True (nullQName {namePrefix = "http",

localPart = "//www.w3.org/2001/XMLSchema#" ++ numberName f})

$ setName literalK $ mwText $ show f

xmlIndividual :: IRI -> Element

xmlIndividual iri =

mwNameIRI (if isAnonymous iri then anonymousIndividualK

else namedIndividualK) iri

xmlFVPair :: (ConstrainingFacet, RestrictionValue) -> Element

xmlFVPair (cf, rv) = setDt False cf $ makeElement facetRestrictionK

[xmlLiteral rv]

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

DataType dt cfl ->

let dtelem = mwNameIRI datatypeK dt

in if null cfl then dtelem

else makeElement datatypeRestrictionK

$ dtelem : map xmlFVPair cfl

DataJunction jt drl -> makeElement (

case jt of

IntersectionOf -> dataIntersectionOfK

UnionOf -> dataUnionOfK)

$ map xmlDataRange drl

DataComplementOf drn -> makeElement dataComplementOfK

[xmlDataRange drn]

DataOneOf ll -> makeElement dataOneOfK

$ map xmlLiteral ll

xmlClassExpression :: ClassExpression -> Element

xmlClassExpression ce = case ce of

Expression c -> mwNameIRI classK c

ObjectJunction jt cel -> makeElement (

case jt of

IntersectionOf -> objectIntersectionOfK

UnionOf -> objectUnionOfK)

$ map xmlClassExpression cel

ObjectComplementOf cex -> makeElement objectComplementOfK

[xmlClassExpression cex]

ObjectOneOf il -> makeElement objectOneOfK

$ map xmlIndividual il

ObjectValuesFrom qt ope cex -> makeElement (

case qt of

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 (

case ct of

MinCardinality -> objectMinCardinalityK

MaxCardinality -> objectMaxCardinalityK

ExactCardinality -> objectExactCardinalityK)

$ xmlObjProp op :

case mce of

Nothing -> []

Just cexp -> [xmlClassExpression cexp]

DataValuesFrom qt dp dr -> makeElement (

case qt of

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 (

case ct of

MinCardinality -> dataMinCardinalityK

MaxCardinality -> dataMaxCardinalityK

ExactCardinality -> dataExactCardinalityK)

$ mwNameIRI dataPropertyK dp :

case mdr of

Nothing -> []

Just dr -> [xmlDataRange dr]

xmlAnnotation :: Annotation -> Element

xmlAnnotation (Annotation al ap av) = makeElement annotationK

$ map xmlAnnotation al ++ [mwNameIRI annotationPropertyK ap,

case av of

AnnValue iri -> xmlSubject iri

AnnValLit l -> xmlLiteral l]

xmlSubject :: IRI -> Element

xmlSubject iri = if isAnonymous iri then xmlIndividual iri

else mwSimpleIRI iri

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

in zip annos other

xmlLFB :: Extended -> Maybe Relation -> ListFrameBit -> [Element]

xmlLFB ext mr lfb = case lfb of

AnnotationBit al ->

let list = xmlAL mwSimpleIRI al

SimpleEntity (Entity _ ap) = ext

in case fromMaybe (error "expected domain, range, subproperty") mr of

SubPropertyOf ->

let list2 = xmlAL (mwNameIRI annotationPropertyK) al

in make1 True subAnnotationPropertyOfK annotationPropertyK

mwNameIRI ap list2

DRRelation ADomain -> make1 True annotationPropertyDomainK

annotationPropertyK mwNameIRI ap list

DRRelation ARange -> make1 True annotationPropertyRangeK

annotationPropertyK mwNameIRI ap list

_ -> error "bad annotation bit"

ExpressionBit al ->

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

SubClass -> subClassOfK

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

mwNameIRI ent list

NamedIndividual -> make2 False classAssertionK

xmlIndividual ent list

_ -> error "bad expression bit"

ObjectBit al ->

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)"

) xmlObjProp o list

_ -> error "bad object bit"

DataBit al ->

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)"

) xmlIndividual i list

_ -> 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

DataPropRange al ->

let SimpleEntity (Entity DataProperty dp) = ext

list = xmlAL xmlDataRange al

in make1 True dataPropertyRangeK dataPropertyK mwNameIRI dp list

IndividualFacts al ->

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 ->

makeElement (case pn of

Positive -> objectPropertyAssertionK

Negative -> negativeObjectPropertyAssertionK

) $ x ++ [xmlObjProp op] ++ map xmlIndividual [i, ind]

DataPropertyFact pn dp lit ->

makeElement (case pn of

Positive -> dataPropertyAssertionK

Negative -> negativeDataPropertyAssertionK

) $ x ++ [mwNameIRI dataPropertyK dp] ++

[xmlIndividual i] ++ [xmlLiteral lit]

) list

xmlAssertion :: IRI -> Annotations -> [Element]

xmlAssertion iri = map (\ (Annotation as ap av) ->

makeElement annotationAssertionK $ xmlAnnotations as

++ [mwNameIRI annotationPropertyK ap]

++ [xmlSubject iri, case av of

AnnValue avalue -> xmlSubject avalue

AnnValLit l -> xmlLiteral l])

xmlAFB :: Extended -> Annotations -> AnnFrameBit -> [Element]

xmlAFB ext anno afb = case afb of

AnnotationFrameBit ty -> case ext of

SimpleEntity ent -> case ty of

Declaration -> [makeElement declarationK

$ xmlAnnotations anno ++ [xmlEntity ent]]

Assertion -> if null anno then [makeElement declarationK

[xmlEntity ent]]

else let Entity _ iri = ent in xmlAssertion iri anno

Misc ans -> let [Annotation _ iri _] = ans in xmlAssertion iri anno

ClassEntity ent -> case ent of

Expression c -> [makeElement declarationK

$ xmlAnnotations anno ++ [xmlEntity $ Entity Class c]]

_ -> [] -- very rare cases

ObjectEntity ent -> case ent of

ObjectProp o -> [makeElement declarationK

$ xmlAnnotations anno ++

[xmlEntity $ Entity ObjectProperty o]]

_ -> [] -- very rare cases

DataFunctional ->

let SimpleEntity (Entity _ dp) = ext

in [makeElement functionalDataPropertyK

$ xmlAnnotations anno ++ [mwNameIRI dataPropertyK dp]]

DatatypeBit dr ->

let SimpleEntity (Entity _ dt) = ext

in [makeElement datatypeDefinitionK

$ xmlAnnotations anno ++ [mwNameIRI datatypeK dt,

xmlDataRange dr]]

ClassDisjointUnion cel ->

let ClassEntity c = ext

in [makeElement disjointUnionK

$ xmlAnnotations anno ++ map xmlClassExpression (c : cel)]

ClassHasKey op dp ->

let ClassEntity c = ext

in [makeElement hasKeyK

$ xmlAnnotations anno ++ [xmlClassExpression c]

++ map xmlObjProp op ++ map (mwNameIRI dataPropertyK) dp]

ObjectSubPropertyChain opl ->

let ObjectEntity op = ext

xmlop = map xmlObjProp opl

in [makeElement subObjectPropertyOfK

$ xmlAnnotations anno ++

[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

signToDec :: Sign -> [Element]

signToDec s =

let c = Set.toList $ concepts s

op = Set.toList $ objectProperties s

dp = Set.toList $ dataProperties s

ap = Set.toList $ annotationRoles s

dt = Set.toList $ datatypes s

i = Set.toList $ individuals s

in map (makeElementWith1 declarationK . mwNameIRI classK) c

++ map (makeElementWith1 declarationK . mwNameIRI objectPropertyK) op

++ map (makeElementWith1 declarationK . mwNameIRI dataPropertyK) dp

++ map (makeElementWith1 declarationK . mwNameIRI annotationPropertyK) ap

++ map (makeElementWith1 declarationK . mwNameIRI datatypeK) dt

++ map (makeElementWith1 declarationK . mwNameIRI namedIndividualK) i

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 = let allpm = Map.union pm predefPrefixes in

map (setName prefixK . set1Map) $ Map.toList allpm

setOntIRI :: OntologyIRI -> Element -> Element

setOntIRI iri e =

if elem iri [nullQName, dummyQName] then e

else e {elAttribs = Attr {attrKey = makeQN "ontologyIRI",

attrVal = showIRI iri} : elAttribs e}

setBase :: String -> Element -> Element

setBase s e = e {elAttribs = Attr {attrKey = nullQN {qName = "base",

qPrefix = Just "xml"}, attrVal = s} : elAttribs e}

setXMLNS :: Element -> Element

setXMLNS e = e {elAttribs = Attr {attrKey = makeQN "xmlns", attrVal =

"http://www.w3.org/2002/07/owl#"} : elAttribs e}

xmlOntologyDoc :: Sign -> OntologyDocument -> Element

xmlOntologyDoc s od =

let ont = ontology od

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)

++ signToDec s

mkODoc :: Sign -> [Named Axiom] -> String

mkODoc s na = ppTopElement $ xmlOntologyDoc s $ emptyOntologyDoc

{

ontology = emptyOntologyD

{

ontFrames = map (axToFrame . sentence) na

},

prefixDeclaration = prefixMap s

}