content: {- |
  Module      :  ./OWL2/XMLConversion.hs
  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 Common.GlobalAnnotations as GA (PrefixMap)
  import Common.IRI hiding (showIRI)
  import Common.Id
  
  import OWL2.AS
  import OWL2.Sign
  import OWL2.XMLKeywords
  import OWL2.Keywords (DatatypeFacet(..))
  
  import Text.XML.Light
  
  import Data.Maybe
  import qualified Data.Set as Set
  import qualified Data.Map as Map
  
  -- | prints the IRI
  showIRI :: IRI -> String
  showIRI iri = (if isURN iri then showURN else showIRIFull) iri {hasAngles = False}
  
  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 (ty, fn)
              | isAbbrev iri = ("abbreviatedIRI", showIRICompact)
              | isBlankNode iri = (nodeID, showIRI)
              | otherwise = (iriK, showIRI)
      in e {elAttribs = [Attr {attrKey = makeQN ty,
                               attrVal = fn $ 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 hasFullIRI s then iriK
                            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}]}
  
  -- | the reverse of @properFacet@ in "OWL2.XML"
  correctFacet :: ConstrainingFacet -> ConstrainingFacet
  correctFacet c = case getPredefName c of
      ">" -> facetToIRINoSign MAXEXCLUSIVE
      "<" -> facetToIRINoSign MINEXCLUSIVE
      ">=" -> facetToIRINoSign MAXINCLUSIVE
      "<=" -> facetToIRINoSign MININCLUSIVE
      _ -> c
  
  -- | 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 $ if b then setReservedPrefix dt else correctFacet 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 plainDatatypeIRI part
    NumberLit f -> setDt True (nullIRI {iriScheme = "http:",
          iriPath = stringToId $ "//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 (head 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
          AnnAnInd iri -> xmlSubject iri]
  
  xmlSubject :: IRI -> Element
  xmlSubject iri = if isAnonymous iri then xmlIndividual iri
                    else mwSimpleIRI iri
  
  xmlAnnotations :: [Annotation] -> [Element]
  xmlAnnotations = map xmlAnnotation
  
  xmlAssertion :: IRI -> [Annotation] -> [Element]
  xmlAssertion iri = map (\ (Annotation as ap av) ->
      makeElement annotationAssertionK $ xmlAnnotations as
          ++ [mwNameIRI annotationPropertyK ap]
          ++ [xmlSubject iri, case av of
                  AnnValue avalue -> xmlSubject avalue
                  AnnAnInd ind -> xmlSubject ind
                  AnnValLit l -> xmlLiteral l])
  
  xmlAxioms :: Axiom -> [Element]
  xmlAxioms axiom = case axiom of
      Declaration anns entity -> 
          [makeElement declarationK $ xmlAnnotations anns ++ [xmlEntity entity]]
  
      ClassAxiom clAxiom -> case clAxiom of
          SubClassOf anns sub sup -> make2 True subClassOfK xmlClassExpression
              sub [(xmlAnnotations anns, xmlClassExpression sup)]
          EquivalentClasses anns ces ->
              [makeElement equivalentClassesK
                  $ xmlAnnotations anns ++ map xmlClassExpression ces]
          DisjointClasses anns ces ->
              [makeElement disjointClassesK
                  $ xmlAnnotations anns ++ map xmlClassExpression ces]
          DisjointUnion anns clIri ces ->
              [makeElement disjointUnionK $ xmlAnnotations anns
                  ++ map xmlClassExpression ((Expression clIri) : ces)]
  
      ObjectPropertyAxiom opAxiom -> case opAxiom of
          SubObjectPropertyOf anns sub sup -> case sub of
              SubObjPropExpr_obj op ->
                  make2 True subObjectPropertyOfK xmlObjProp op
                      [(xmlAnnotations anns, xmlObjProp sup)]
              SubObjPropExpr_exprchain ops ->
                  let xmlop = map xmlObjProp ops
                  in [makeElement subObjectPropertyOfK
                          $ xmlAnnotations anns
                          ++ [makeElement objectPropertyChainK xmlop
                              , xmlObjProp sup]]
  
          EquivalentObjectProperties anns ops ->
              [makeElement equivalentObjectPropertiesK
                  $ xmlAnnotations anns ++ map xmlObjProp ops]
              
          DisjointObjectProperties anns ops ->
              [makeElement disjointObjectPropertiesK
                  $ xmlAnnotations anns ++ map xmlObjProp ops]
  
          InverseObjectProperties anns op1 op2 ->
              make2 True inverseObjectPropertiesK xmlObjProp op1
                  [(xmlAnnotations anns, xmlObjProp op2)]
  
          ObjectPropertyDomain anns op ce ->
              make2 True objectPropertyDomainK xmlObjProp op
                  [(xmlAnnotations anns, xmlClassExpression ce)]
  
          ObjectPropertyRange anns op ce ->
              make2 True objectPropertyRangeK xmlObjProp op
                  [(xmlAnnotations anns, xmlClassExpression ce)]
  
          FunctionalObjectProperty anns op -> 
              [makeElement functionalObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
          InverseFunctionalObjectProperty anns op ->
              [makeElement inverseFunctionalObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
          ReflexiveObjectProperty anns op ->
              [makeElement reflexiveObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
          IrreflexiveObjectProperty anns op ->
              [makeElement irreflexiveObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
          SymmetricObjectProperty anns op ->
              [makeElement symmetricObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
          AsymmetricObjectProperty anns op ->
              [makeElement asymmetricObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
          TransitiveObjectProperty anns op ->
              [makeElement transitiveObjectPropertyK
                  $ xmlAnnotations anns ++ [xmlObjProp op]]
  
      DataPropertyAxiom dpAxiom -> case dpAxiom of
          SubDataPropertyOf anns sub sup -> 
              make1 True subDataPropertyOfK dataPropertyK
                  mwNameIRI sub [(xmlAnnotations anns, mwNameIRI dataPropertyK sup)]
  
          EquivalentDataProperties anns dps ->
              [makeElement equivalentDataPropertiesK
                  $ xmlAnnotations anns ++ map (mwNameIRI dataPropertyK) dps]
  
          DisjointDataProperties anns dps ->
              [makeElement disjointDataPropertiesK
                  $ xmlAnnotations anns ++ map (mwNameIRI dataPropertyK) dps]
  
          DataPropertyDomain anns dpe ce ->
              make1 True dataPropertyDomainK dataPropertyK mwNameIRI dpe
                  [(xmlAnnotations anns, xmlClassExpression ce)]
  
          DataPropertyRange anns dpe dr -> 
              make1 True dataPropertyRangeK dataPropertyK mwNameIRI dpe
                  [(xmlAnnotations anns, xmlDataRange dr)]
  
          FunctionalDataProperty anns dpe ->
              [makeElement functionalDataPropertyK
                  $ xmlAnnotations anns ++ [mwNameIRI dataPropertyK dpe]]
  
      DatatypeDefinition anns dt dr ->
          [makeElement datatypeDefinitionK $ xmlAnnotations anns
              ++ [mwNameIRI datatypeK dt, xmlDataRange dr]]
  
      HasKey anns ce ops dps -> 
          [makeElement hasKeyK $ xmlAnnotations anns ++ [xmlClassExpression ce]
              ++ map xmlObjProp ops ++ map (mwNameIRI dataPropertyK) dps]
  
      Assertion aAxiom -> case aAxiom of
          SameIndividual anns inds ->
              [makeElement sameIndividualK
                  $ xmlAnnotations anns ++ map xmlIndividual inds]
  
          DifferentIndividuals anns inds ->
              [makeElement differentIndividualsK
                  $ xmlAnnotations anns ++ map xmlIndividual inds]
  
          ClassAssertion anns ce ind ->
              make2 False classAssertionK xmlIndividual ind
                  [(xmlAnnotations anns, xmlClassExpression ce)]
  
          ObjectPropertyAssertion anns op sInd tInd ->
              [makeElement objectPropertyAssertionK
                  $ xmlAnnotations anns ++ [xmlObjProp op]
                  ++ map xmlIndividual [sInd, tInd]]
  
          NegativeObjectPropertyAssertion anns op sInd tInd ->
              [makeElement negativeObjectPropertyAssertionK
                  $ xmlAnnotations anns ++ [xmlObjProp op]
                  ++ map xmlIndividual [sInd, tInd]]
  
          DataPropertyAssertion anns dp sInd tVal ->
              [makeElement dataPropertyAssertionK
                  $ xmlAnnotations anns ++ [mwNameIRI dataPropertyK dp]
                  ++ [xmlIndividual sInd] ++ [xmlLiteral tVal]]
  
          NegativeDataPropertyAssertion anns dp sInd tVal ->
              [makeElement negativeDataPropertyAssertionK
                  $ xmlAnnotations anns ++ [mwNameIRI dataPropertyK dp]
                  ++ [xmlIndividual sInd] ++ [xmlLiteral tVal]]
  
      AnnotationAxiom annAxiom -> case annAxiom of
          AnnotationAssertion anns prop subj value -> 
              let iri = case subj of
                      AnnSubIri i -> i
                      AnnSubAnInd i -> i
              in xmlAssertion iri [Annotation anns prop value]
  
          SubAnnotationPropertyOf anns sub sup ->
              make1 True subAnnotationPropertyOfK annotationPropertyK
                  mwNameIRI sub
                  [(xmlAnnotations anns, mwNameIRI annotationPropertyK sup)]
  
          AnnotationPropertyDomain anns prop iri ->
              make1 True annotationPropertyDomainK
                  annotationPropertyK mwNameIRI prop
                  [(xmlAnnotations anns, mwSimpleIRI iri)]
  
          AnnotationPropertyRange anns prop iri ->
              make1 True annotationPropertyRangeK
                  annotationPropertyK mwNameIRI prop
                  [(xmlAnnotations anns, mwSimpleIRI iri)]
  
  
      Rule rule -> case rule of
          DLSafeRule anns bd hd -> 
              [makeElement dlSafeRuleK $ xmlAnnotations anns
                  ++ [makeElement "Body" $ map xmlAtom bd
                      , makeElement "Head" $ map xmlAtom hd]] 
          DGRule _ _ _ -> error "DG Rules are not supported in XML yet"
      DGAxiom _ _ _ _ _ -> error "DG Axioms are not supported in XML yet"
  
  xmlAtom :: Atom -> Element
  xmlAtom atom = case atom of
      ClassAtom ce ia -> makeElement classAtomK
          [xmlClassExpression ce, xmlIndividualArg ia]
  
      DataRangeAtom dr da -> makeElement dataRangeAtomK
          [xmlDataRange dr, xmlDataArg da]
  
      ObjectPropertyAtom oe ia1 ia2 -> makeElement objectPropertyAtomK
          [xmlObjProp oe, xmlIndividualArg ia1, xmlIndividualArg ia2]
  
      DataPropertyAtom dp ia da -> makeElement dataPropertyAtomK
          [mwNameIRI dataPropertyK dp, xmlIndividualArg ia, xmlDataArg da]
  
      BuiltInAtom iri das -> setIRI iri $ makeElement builtInAtomK 
          $ map xmlDataArg das
  
      SameIndividualAtom ia1 ia2 -> makeElement sameIndividualAtomK
          . map xmlIndividualArg $ [ia1, ia2]
  
      DifferentIndividualsAtom ia1 ia2 -> makeElement differentIndividualsAtomK
          . map xmlIndividualArg $ [ia1, ia2]
  
      _ -> error "XML Converter: Uknown atom"
  
  
  xmlIndividualArg :: IndividualArg -> Element
  xmlIndividualArg ia = case ia of
      IArg i -> mwNameIRI namedIndividualK i
      IVar i -> mwNameIRI variableK i
  
  xmlDataArg :: DataArg -> Element
  xmlDataArg da = case da of
      DArg lit -> xmlLiteral lit
      DVar iri -> mwNameIRI variableK iri
  
  xmlUnknownArg :: UnknownArg -> Element
  xmlUnknownArg ua = case ua of
      IndividualArg ia -> xmlIndividualArg ia
      DataArg da -> xmlDataArg da
      Variable v -> mwNameIRI variableK v
  
  mkElemeDecl :: Sign -> String -> (Sign -> Set.Set IRI) -> [Element]
  mkElemeDecl s k f = map (makeElementWith1 declarationK . mwNameIRI k)
      $ Set.toList $ f s
  
  -- | converts the signature to declarations
  signToDec :: Sign -> [Element]
  signToDec s = concatMap (uncurry $ mkElemeDecl s)
      [ (classK, concepts)
      , (objectPropertyK, objectProperties)
      , (dataPropertyK, dataProperties)
      , (annotationPropertyK, annotationRoles)
      , (datatypeK, datatypes)
      , (namedIndividualK, individuals)]
  
  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, IRI) -> Element
  set1Map (s, iri) = setPref s $ mwIRI iri
  
  xmlPrefixes :: GA.PrefixMap -> [Element]
  xmlPrefixes pm = let allpm = Map.union pm $ predefPrefixesGA in
      map (setName prefixK . set1Map) $ Map.toList allpm
  
  setOntIRI :: Maybe OntologyIRI -> Element -> Element
  setOntIRI mIri e = case mIri of
      Nothing -> e
      Just iri -> e { elAttribs = Attr {
          attrKey = makeQN "ontologyIRI"
        , attrVal = showIRI iri } : elAttribs e }
  
  setOntVersionIRI :: Maybe OntologyIRI -> Element -> Element
  setOntVersionIRI mIri e = case mIri of
      Nothing -> e
      Just iri -> e { elAttribs = Attr {
          attrKey = makeQN "versionIRI"
        , 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 = showIRI $ fromMaybe dummyIRI $ Map.lookup "" pd
      in setBase emptyPref $ setXMLNS
          $ setOntIRI (mOntologyIRI ont)
          $ setOntVersionIRI (mOntologyVersion ont)
          $ makeElement "Ontology" $ xmlPrefixes pd
              ++ map xmlImport (importsDocuments ont)
              ++ concatMap xmlAxioms (axioms ont) -- change xmlFrames 
              ++ concatMap xmlAnnotations [(ontologyAnnotation ont)]
              ++ signToDec s
  
  -- TODO: commented out in 1993
  mkODoc :: Sign -> [Named Axiom] -> String
  mkODoc s = ppTopElement . xmlOntologyDoc s
      . OntologyDocument (OntologyMetadata AS) (changePrefixMapTypeToGA $ prefixMap s)
      . Ontology Nothing Nothing [] [] . map sentence
  