bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maedermodule OWL2.Rename where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport OWL2.AS

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport OWL2.MS

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport OWL2.Sign

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport qualified Data.Map as Map

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport qualified Data.Set as Set

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport qualified Common.AS_Annotation as Common.Annotation

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport Data.List (find, nub)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport Data.Maybe

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport Data.Char (isDigit)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederimport Common.Result

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maedertype TranslationMap = Map.Map String String

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederclass PrefixClass a where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv :: TranslationMap -> a -> a

c04cc42aa672aa49b45005e6eed77cc80e0d6ae0Christian Maeder

329c739bc05b8ce8d54f81071d0826ff771d1f78Christian MaedermaybeRename :: (PrefixClass a) => TranslationMap -> Maybe a -> Maybe a

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian MaedermaybeRename tMap = fmap $ mv tMap

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass PrefixMap where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap oldPs =

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder foldl (\ ns (pre, ouri) ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Map.insert (Map.findWithDefault pre pre tMap) ouri ns)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Map.empty $ Map.toList oldPs

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass QName where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap old = let pre = namePrefix old in

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder old { namePrefix = Map.findWithDefault pre pre tMap }

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass Sign where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap (Sign p1 p2 p3 p4 p5 p6 p7) =

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Sign (Set.map (mv tMap) p1)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder (Set.map (mv tMap) p2)

ac4396c9f44a76c5c97925954ee49b4a91d8dd88Christian Maeder (Set.map (mv tMap) p3)

ac4396c9f44a76c5c97925954ee49b4a91d8dd88Christian Maeder (Set.map (mv tMap) p4)

ac4396c9f44a76c5c97925954ee49b4a91d8dd88Christian Maeder (Set.map (mv tMap) p5)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder (Set.map (mv tMap) p6)

c04cc42aa672aa49b45005e6eed77cc80e0d6ae0Christian Maeder (mv tMap p7)

c04cc42aa672aa49b45005e6eed77cc80e0d6ae0Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass (DomainOrRangeOrFunc a) where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap dor = case dor of

a38f3d84e592184830fa308c5dab3f7c71e4464fChristian Maeder DomainOrRange ty des -> DomainOrRange ty $ mv tMap des

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder RDRange dr -> RDRange $ mv tMap dr

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder _ -> dor

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass SignAxiom where

329c739bc05b8ce8d54f81071d0826ff771d1f78Christian Maeder mv tMap signAxiom =

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder case signAxiom of

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Subconcept cId1 cId2 ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Subconcept (mv tMap cId1)

a208edf329751a734895216ad5b0e334a9ac6a44Christian Maeder (mv tMap cId2)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Role rdr id1 ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Role (mv tMap rdr) (mv tMap id1)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Data rdr id1 ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Data (mv tMap rdr) (mv tMap id1)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Conceptmembership iId des ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Conceptmembership (mv tMap iId)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder (mv tMap des)

c04cc42aa672aa49b45005e6eed77cc80e0d6ae0Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass (Common.Annotation.Named Axiom) where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap sent = sent {

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Common.Annotation.sentence = mv tMap

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder (Common.Annotation.sentence sent) }

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass Entity where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap (Entity ty euri) = Entity ty $ mv tMap euri

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass Literal where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap lit = case lit of

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Literal l (Typed curi) ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder Literal l $ Typed $ mv tMap curi

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder _ -> lit

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass ObjectPropertyExpression where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap opExp = case opExp of

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder ObjectProp opuri -> ObjectProp (mv tMap opuri)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder ObjectInverseOf invOp -> ObjectInverseOf (mv tMap invOp)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maederinstance PrefixClass DataRange where

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder mv tMap dr =

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder let rnRest (facet, value) = (facet, mv tMap value)

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder in case dr of

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder DataType druri restrList ->

bff4b3f816be4c1e1d8ded76f1d5af786839e1a9Christian Maeder DataType (mv tMap druri) (map rnRest restrList)

DataJunction ty drlist -> DataJunction ty (map (mv tMap) drlist)

DataComplementOf dataRange -> DataComplementOf (mv tMap dataRange)

DataOneOf constList -> DataOneOf (map (mv tMap) constList)

instance PrefixClass ClassExpression where

mv tMap desc = case desc of

Expression curi -> Expression (mv tMap curi)

ObjectJunction ty descList ->

ObjectJunction ty (map (mv tMap) descList)

ObjectComplementOf desc' -> ObjectComplementOf (mv tMap desc')

ObjectOneOf indsList -> ObjectOneOf (map (mv tMap) indsList)

ObjectValuesFrom ty opExp desc' -> ObjectValuesFrom ty

(mv tMap opExp) (mv tMap desc')

ObjectHasSelf opExp -> ObjectHasSelf (mv tMap opExp)

ObjectHasValue opExp indUri -> ObjectHasValue

(mv tMap opExp) (mv tMap indUri)

ObjectCardinality (Cardinality ty card opExp maybeDesc) ->

ObjectCardinality $ Cardinality ty card

(mv tMap opExp) (maybeRename tMap maybeDesc)

DataValuesFrom ty dpExp dataRange ->

DataValuesFrom ty (mv tMap dpExp) (mv tMap dataRange)

DataHasValue dpExp const' -> DataHasValue

(mv tMap dpExp) (mv tMap const')

DataCardinality (Cardinality ty card dpExp maybeRange) ->

DataCardinality $ Cardinality ty card

(mv tMap dpExp) (maybeRename tMap maybeRange)

instance PrefixClass Annotation where

mv tMap anno = case anno of

Annotation annos ap av -> Annotation (map (mv tMap) annos)

(mv tMap ap) (mv tMap av)

instance PrefixClass AnnotationValue where

mv ns av = case av of

AnnValue iri -> AnnValue (mv ns iri)

AnnValLit l -> AnnValLit (mv ns l)

instance PrefixClass Annotations where

mv tMap = map (mv tMap)

instance PrefixClass a => PrefixClass (AnnotatedList a) where

mv tMap = map (\ (ans, b) -> (mv tMap ans, mv tMap b))

instance PrefixClass ListFrameBit where

mv tMap lfb = case lfb of

AnnotationBit anl -> AnnotationBit (mv tMap anl)

ExpressionBit anl -> ExpressionBit (mv tMap anl)

ObjectBit anl -> ObjectBit (mv tMap anl)

DataBit anl -> DataBit (mv tMap anl)

IndividualSameOrDifferent anl ->

IndividualSameOrDifferent (mv tMap anl)

DataPropRange anl -> DataPropRange (mv tMap anl)

IndividualFacts ans -> IndividualFacts (mv tMap ans)

_ -> lfb

instance PrefixClass AnnFrameBit where

mv tMap afb = case afb of

DatatypeBit dr -> DatatypeBit (mv tMap dr)

ClassDisjointUnion cel -> ClassDisjointUnion (map (mv tMap) cel)

ClassHasKey ol dl -> ClassHasKey (map (mv tMap) ol) (map (mv tMap) dl)

ObjectSubPropertyChain ol -> ObjectSubPropertyChain (map (mv tMap) ol)

_ -> afb

instance PrefixClass FrameBit where

mv tMap fb = case fb of

ListFrameBit mr lfb -> ListFrameBit mr (mv tMap lfb)

AnnFrameBit ans afb -> AnnFrameBit (mv tMap ans) (mv tMap afb)

instance PrefixClass Extended where

mv tMap ex = case ex of

Misc ans -> Misc $ mv tMap ans

SimpleEntity e -> SimpleEntity $ mv tMap e

ClassEntity ce -> ClassEntity $ mv tMap ce

ObjectEntity op -> ObjectEntity $ mv tMap op

instance PrefixClass Frame where

mv tMap (Frame ex fbl) = Frame (mv tMap ex) (map (mv tMap) fbl)

instance PrefixClass Axiom where

mv tMap (PlainAxiom ex fbl) = PlainAxiom (mv tMap ex) (mv tMap fbl)

instance PrefixClass Fact where

mv tMap f = case f of

ObjectPropertyFact pn op i -> ObjectPropertyFact pn (mv tMap op) (mv tMap i)

DataPropertyFact pn dp l -> DataPropertyFact pn (mv tMap dp) (mv tMap l)

instance PrefixClass OntologyDocument where

mv tMap ( OntologyDocument pm onto) =

OntologyDocument (mv tMap pm) (mv tMap onto)

instance PrefixClass Ontology where

mv tMap ( Ontology ouri impList anList f) =

Ontology (mv tMap ouri) (map (mv tMap) impList)

(map (mv tMap) anList) (map (mv tMap) f)

testAndInteg :: (String, String)

-> (PrefixMap, TranslationMap) -> (PrefixMap, TranslationMap)

testAndInteg (pre, oiri) (old, tm) = case Map.lookup pre old of

Just iri ->

if oiri == iri then (old, tm)

else let pre' = disambiguateName pre old

in (Map.insert pre' oiri old, Map.insert pre pre' tm)

Nothing -> (Map.insert pre oiri old, tm)

disambiguateName :: String -> PrefixMap -> String

disambiguateName name nameMap =

let newname = reverse . dropWhile isDigit $ reverse name

in fromJust $ find (not . flip Map.member nameMap)

[newname ++ show (i :: Int) | i <- [1 ..]]

uniteSign :: Sign -> Sign -> Result Sign

uniteSign s1 s2 = do

let (pm, tm) = integPref (prefixMap s1) (prefixMap s2)

if Map.null tm then return (addSign s1 s2) {prefixMap = pm}

else fail "Static analysis could not unite signatures"

integPref :: PrefixMap -> PrefixMap

-> (PrefixMap, TranslationMap)

integPref oldNsMap testNsMap =

foldr testAndInteg (oldNsMap, Map.empty) (Map.toList testNsMap)

newOid :: OntologyIRI -> OntologyIRI -> OntologyIRI

newOid id1 id2 =

let lid1 = localPart id1

lid2 = localPart id2

in if null lid1 then id2

else if null lid2 || id1 == id2 then id1

else id1 { localPart = uriToName lid1 ++ "_" ++ uriToName lid2 }

integrateOntologyDoc :: OntologyDocument -> OntologyDocument

-> OntologyDocument

integrateOntologyDoc of1@( OntologyDocument ns1

( Ontology oid1 imp1 anno1 frames1))

of2@( OntologyDocument ns2

( Ontology oid2 imp2 anno2 frames2)) =

if of1 == of2 then of1

else

let (newPref, tm) = integPref ns1 ns2

in OntologyDocument newPref

(Ontology (newOid oid1 oid2) (nub $ imp1 ++ map (mv tm) imp2)

(nub $ anno1 ++ map (mv tm) anno2)

(nub $ frames1 ++ map (mv tm) frames2))

uriToName :: String -> String

uriToName str = let

str' = case str of

'"' : _ -> read str

_ -> str

in takeWhile (/= '.') $ reverse $ case takeWhile (/= '/') $ reverse str' of

'#' : r -> r

r -> r