{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Module      :  ./OWL2/Rename.hs
Copyright   :  (c) Felix Gabriel Mance
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  f.mance@jacobs-university.de
Stability   :  provisional
Portability :  portable

Renames prefixes in OntologyDocuments, so that there are
no prefix clashes
-}

module OWL2.Rename where

import OWL2.AS
import Common.IRI
import Common.Id (stringToId)
-- import OWL2.MS
import OWL2.Sign
import OWL2.Function

import Data.Char (isDigit)
import Data.List (find, nub)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Control.Monad.Fail as Fail

import Common.Result

testAndInteg :: (String, String)
     -> (PrefixMap, StringMap) -> (PrefixMap, StringMap)
testAndInteg :: (String, String)
-> (PrefixMap, PrefixMap) -> (PrefixMap, PrefixMap)
testAndInteg (pre :: String
pre, oiri :: String
oiri) (old :: PrefixMap
old, tm :: PrefixMap
tm) = case String -> PrefixMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
pre PrefixMap
old of
  Just anIri :: String
anIri ->
   if String
oiri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
anIri then (PrefixMap
old, PrefixMap
tm)
    else let pre' :: String
pre' = String -> PrefixMap -> String
disambiguateName String
pre PrefixMap
old
         in (String -> String -> PrefixMap -> PrefixMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
pre' String
oiri PrefixMap
old, String -> String -> PrefixMap -> PrefixMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
pre String
pre' PrefixMap
tm)
  Nothing -> (String -> String -> PrefixMap -> PrefixMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
pre String
oiri PrefixMap
old, PrefixMap
tm)

disambiguateName :: String -> PrefixMap -> String
disambiguateName :: String -> PrefixMap -> String
disambiguateName n :: String
n nameMap :: PrefixMap
nameMap =
  let nm :: String
nm = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n then "n" else String
n  -- change other empty prefixes to "n..."
      newname :: String
newname = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isDigit (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
nm
      x :: Maybe String
x =  (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> PrefixMap -> Bool) -> PrefixMap -> String -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> PrefixMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PrefixMap
nameMap)
           [String
newname String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i :: Int) | Int
i <- [1 ..]]
  in case Maybe String
x of
      Just y :: String
y -> String
y
      Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "could not disambiguate " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                         " using " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrefixMap -> String
forall a. Show a => a -> String
show PrefixMap
nameMap 

uniteSign :: Sign -> Sign -> Result Sign
uniteSign :: Sign -> Sign -> Result Sign
uniteSign s1 :: Sign
s1 s2 :: Sign
s2 = do
    let (pm :: PrefixMap
pm, tm :: PrefixMap
tm) = PrefixMap -> PrefixMap -> (PrefixMap, PrefixMap)
integPref (Sign -> PrefixMap
prefixMap Sign
s1) (Sign -> PrefixMap
prefixMap Sign
s2)
    if PrefixMap -> Bool
forall k a. Map k a -> Bool
Map.null PrefixMap
tm then Sign -> Result Sign
forall (m :: * -> *) a. Monad m => a -> m a
return (Sign -> Sign -> Sign
addSign Sign
s1 Sign
s2) {prefixMap :: PrefixMap
prefixMap = PrefixMap
pm}
      else String -> Result Sign
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Static analysis could not unite signatures"

intersectSign :: Sign -> Sign -> Result Sign
intersectSign :: Sign -> Sign -> Result Sign
intersectSign s1 :: Sign
s1 s2 :: Sign
s2 = do
   let (pm :: PrefixMap
pm, tm :: PrefixMap
tm) = PrefixMap -> PrefixMap -> (PrefixMap, PrefixMap)
integPref (Sign -> PrefixMap
prefixMap Sign
s1) (PrefixMap -> (PrefixMap, PrefixMap))
-> PrefixMap -> (PrefixMap, PrefixMap)
forall a b. (a -> b) -> a -> b
$ Sign -> PrefixMap
prefixMap Sign
s2
   if PrefixMap -> Bool
forall k a. Map k a -> Bool
Map.null PrefixMap
tm then 
     Sign -> Result Sign
forall (m :: * -> *) a. Monad m => a -> m a
return Sign
emptySign{ 
              concepts :: Set Class
concepts = Set Class -> Set Class -> Set Class
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Sign -> Set Class
concepts Sign
s1) (Set Class -> Set Class) -> Set Class -> Set Class
forall a b. (a -> b) -> a -> b
$ Sign -> Set Class
concepts Sign
s2 
            , datatypes :: Set Class
datatypes = Set Class -> Set Class -> Set Class
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Sign -> Set Class
datatypes Sign
s1) (Set Class -> Set Class) -> Set Class -> Set Class
forall a b. (a -> b) -> a -> b
$ Sign -> Set Class
datatypes Sign
s2 
            , objectProperties :: Set Class
objectProperties = Set Class -> Set Class -> Set Class
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Sign -> Set Class
objectProperties Sign
s1) (Set Class -> Set Class) -> Set Class -> Set Class
forall a b. (a -> b) -> a -> b
$ Sign -> Set Class
objectProperties Sign
s2
            , dataProperties :: Set Class
dataProperties = Set Class -> Set Class -> Set Class
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Sign -> Set Class
dataProperties Sign
s1) (Set Class -> Set Class) -> Set Class -> Set Class
forall a b. (a -> b) -> a -> b
$ Sign -> Set Class
dataProperties Sign
s2
            , annotationRoles :: Set Class
annotationRoles = Set Class -> Set Class -> Set Class
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Sign -> Set Class
annotationRoles Sign
s1) (Set Class -> Set Class) -> Set Class -> Set Class
forall a b. (a -> b) -> a -> b
$ Sign -> Set Class
annotationRoles Sign
s2
            , individuals :: Set Class
individuals  = Set Class -> Set Class -> Set Class
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Sign -> Set Class
individuals Sign
s1) (Set Class -> Set Class) -> Set Class -> Set Class
forall a b. (a -> b) -> a -> b
$ Sign -> Set Class
individuals Sign
s2
            , labelMap :: Map Class String
labelMap = Map Class String -> Map Class String -> Map Class String
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection (Sign -> Map Class String
labelMap Sign
s1) (Map Class String -> Map Class String)
-> Map Class String -> Map Class String
forall a b. (a -> b) -> a -> b
$ Sign -> Map Class String
labelMap Sign
s2
            , prefixMap :: PrefixMap
prefixMap =  PrefixMap
pm
            }
    else String -> Result Sign
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Static analysis could not intersect signatures"

integPref :: PrefixMap -> PrefixMap
                    -> (PrefixMap, StringMap)
integPref :: PrefixMap -> PrefixMap -> (PrefixMap, PrefixMap)
integPref oldMap :: PrefixMap
oldMap testMap :: PrefixMap
testMap =
   ((String, String)
 -> (PrefixMap, PrefixMap) -> (PrefixMap, PrefixMap))
-> (PrefixMap, PrefixMap)
-> [(String, String)]
-> (PrefixMap, PrefixMap)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, String)
-> (PrefixMap, PrefixMap) -> (PrefixMap, PrefixMap)
testAndInteg (PrefixMap
oldMap, PrefixMap
forall k a. Map k a
Map.empty) (PrefixMap -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Map.toList PrefixMap
testMap)

newOid :: Maybe OntologyIRI -> Maybe OntologyIRI -> Maybe OntologyIRI
newOid :: Maybe Class -> Maybe Class -> Maybe Class
newOid Nothing Nothing = Maybe Class
forall a. Maybe a
Nothing
newOid (Just id1 :: Class
id1) Nothing = Class -> Maybe Class
forall a. a -> Maybe a
Just Class
id1
newOid Nothing (Just id2 :: Class
id2) = Class -> Maybe Class
forall a. a -> Maybe a
Just Class
id2
newOid (Just id1 :: Class
id1) (Just id2 :: Class
id2) =
  let lid1 :: Id
lid1 = Class -> Id
iriPath Class
id1
      lid2 :: Id
lid2 = Class -> Id
iriPath Class
id2
  in Class -> Maybe Class
forall a. a -> Maybe a
Just (Class -> Maybe Class) -> Class -> Maybe Class
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> String
forall a. Show a => a -> String
show Id
lid1 then Class
id2
      else if (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> String
forall a. Show a => a -> String
show Id
lid2) Bool -> Bool -> Bool
|| Class
id1 Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
id2 then Class
id1
            else Class
id1 { iriPath :: Id
iriPath = String -> Id
stringToId (String -> String
uriToName (Id -> String
forall a. Show a => a -> String
show Id
lid1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
uriToName (Id -> String
forall a. Show a => a -> String
show Id
lid2)) }
  -- todo: improve, see #1597

combineDoc :: OntologyDocument -> OntologyDocument
                      -> OntologyDocument
combineDoc :: OntologyDocument -> OntologyDocument -> OntologyDocument
combineDoc od1 :: OntologyDocument
od1@( OntologyDocument m :: OntologyMetadata
m ns1 :: PrefixMap
ns1
                           ( Ontology oid1 :: Maybe Class
oid1 vid1 :: Maybe Class
vid1 imp1 :: DirectlyImportsDocuments
imp1 anno1 :: OntologyAnnotations
anno1 frames1 :: [Axiom]
frames1))
                      od2 :: OntologyDocument
od2@( OntologyDocument _ ns2 :: PrefixMap
ns2
                           ( Ontology oid2 :: Maybe Class
oid2 vid2 :: Maybe Class
vid2 imp2 :: DirectlyImportsDocuments
imp2 anno2 :: OntologyAnnotations
anno2 frames2 :: [Axiom]
frames2)) =
  if OntologyDocument
od1 OntologyDocument -> OntologyDocument -> Bool
forall a. Eq a => a -> a -> Bool
== OntologyDocument
od2 then OntologyDocument
od1
   else
    let (newPref :: PrefixMap
newPref, tm :: PrefixMap
tm) = PrefixMap -> PrefixMap -> (PrefixMap, PrefixMap)
integPref (PrefixMap -> PrefixMap
changePrefixMapTypeToString PrefixMap
ns1) (PrefixMap -> PrefixMap
changePrefixMapTypeToString PrefixMap
ns2)
    in OntologyMetadata -> PrefixMap -> Ontology -> OntologyDocument
OntologyDocument OntologyMetadata
m (PrefixMap -> PrefixMap
changePrefixMapTypeToGA PrefixMap
newPref)
      (Maybe Class
-> Maybe Class
-> DirectlyImportsDocuments
-> OntologyAnnotations
-> [Axiom]
-> Ontology
Ontology
        (Maybe Class -> Maybe Class -> Maybe Class
newOid Maybe Class
oid1 Maybe Class
oid2)
        (Maybe Class -> Maybe Class -> Maybe Class
newOid Maybe Class
vid1 Maybe Class
vid2)
        (DirectlyImportsDocuments -> DirectlyImportsDocuments
forall a. Eq a => [a] -> [a]
nub (DirectlyImportsDocuments -> DirectlyImportsDocuments)
-> DirectlyImportsDocuments -> DirectlyImportsDocuments
forall a b. (a -> b) -> a -> b
$ DirectlyImportsDocuments
imp1 DirectlyImportsDocuments
-> DirectlyImportsDocuments -> DirectlyImportsDocuments
forall a. [a] -> [a] -> [a]
++ (Class -> Class)
-> DirectlyImportsDocuments -> DirectlyImportsDocuments
forall a b. (a -> b) -> [a] -> [b]
map (Action -> AMap -> Class -> Class
forall a. Function a => Action -> AMap -> a -> a
function Action
Rename (AMap -> Class -> Class) -> AMap -> Class -> Class
forall a b. (a -> b) -> a -> b
$ PrefixMap -> AMap
StringMap PrefixMap
tm) DirectlyImportsDocuments
imp2)
       (OntologyAnnotations -> OntologyAnnotations
forall a. Eq a => [a] -> [a]
nub (OntologyAnnotations -> OntologyAnnotations)
-> OntologyAnnotations -> OntologyAnnotations
forall a b. (a -> b) -> a -> b
$ OntologyAnnotations
anno1 OntologyAnnotations -> OntologyAnnotations -> OntologyAnnotations
forall a. [a] -> [a] -> [a]
++ (Annotation -> Annotation)
-> OntologyAnnotations -> OntologyAnnotations
forall a b. (a -> b) -> [a] -> [b]
map (Action -> AMap -> Annotation -> Annotation
forall a. Function a => Action -> AMap -> a -> a
function Action
Rename (AMap -> Annotation -> Annotation)
-> AMap -> Annotation -> Annotation
forall a b. (a -> b) -> a -> b
$ PrefixMap -> AMap
StringMap PrefixMap
tm) OntologyAnnotations
anno2)
       ([Axiom] -> [Axiom]
forall a. Eq a => [a] -> [a]
nub ([Axiom] -> [Axiom]) -> [Axiom] -> [Axiom]
forall a b. (a -> b) -> a -> b
$ [Axiom]
frames1 [Axiom] -> [Axiom] -> [Axiom]
forall a. [a] -> [a] -> [a]
++ (Axiom -> Axiom) -> [Axiom] -> [Axiom]
forall a b. (a -> b) -> [a] -> [b]
map (Action -> AMap -> Axiom -> Axiom
forall a. Function a => Action -> AMap -> a -> a
function Action
Rename (AMap -> Axiom -> Axiom) -> AMap -> Axiom -> Axiom
forall a b. (a -> b) -> a -> b
$ PrefixMap -> AMap
StringMap PrefixMap
tm) [Axiom]
frames2))

uriToName :: String -> String
uriToName :: String -> String
uriToName str :: String
str = let
  str' :: String
str' = case String
str of
           '"' : _ -> String -> String
forall a. Read a => String -> a
read String
str
           _ -> String
str
  in (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '/') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
str' of
         '#' : r :: String
r -> String
r
         r :: String
r -> String
r

unifyWith1 :: OntologyDocument -> [OntologyDocument] -> [OntologyDocument]
unifyWith1 :: OntologyDocument -> [OntologyDocument] -> [OntologyDocument]
unifyWith1 d :: OntologyDocument
d odl :: [OntologyDocument]
odl = case [OntologyDocument]
odl of
  [] -> []
  [doc :: OntologyDocument
doc] -> [(OntologyDocument, OntologyDocument) -> OntologyDocument
forall a b. (a, b) -> b
snd ((OntologyDocument, OntologyDocument) -> OntologyDocument)
-> (OntologyDocument, OntologyDocument) -> OntologyDocument
forall a b. (a -> b) -> a -> b
$ OntologyDocument
-> OntologyDocument -> (OntologyDocument, OntologyDocument)
unifyTwo OntologyDocument
d OntologyDocument
doc]
  doc1 :: OntologyDocument
doc1 : docs :: [OntologyDocument]
docs ->
    let (merged :: OntologyDocument
merged, newDoc1 :: OntologyDocument
newDoc1) = OntologyDocument
-> OntologyDocument -> (OntologyDocument, OntologyDocument)
unifyTwo OntologyDocument
d OntologyDocument
doc1
    in OntologyDocument
newDoc1 OntologyDocument -> [OntologyDocument] -> [OntologyDocument]
forall a. a -> [a] -> [a]
: OntologyDocument -> [OntologyDocument] -> [OntologyDocument]
unifyWith1 OntologyDocument
merged [OntologyDocument]
docs

{- | takes 2 docs and returns as snd the corrected first one
    and as fst the merge of the two -}
unifyTwo :: OntologyDocument -> OntologyDocument ->
              (OntologyDocument, OntologyDocument)
unifyTwo :: OntologyDocument
-> OntologyDocument -> (OntologyDocument, OntologyDocument)
unifyTwo
  od1 :: OntologyDocument
od1@(OntologyDocument _ pref1 :: PrefixMap
pref1 _)
  od2 :: OntologyDocument
od2@(OntologyDocument _ pref2 :: PrefixMap
pref2 _) =
    let (_, tm :: PrefixMap
tm) = PrefixMap -> PrefixMap -> (PrefixMap, PrefixMap)
integPref (PrefixMap -> PrefixMap
changePrefixMapTypeToString PrefixMap
pref1) (PrefixMap -> PrefixMap
changePrefixMapTypeToString PrefixMap
pref2)
        newod2 :: OntologyDocument
newod2 = Action -> AMap -> OntologyDocument -> OntologyDocument
forall a. Function a => Action -> AMap -> a -> a
function Action
Rename (PrefixMap -> AMap
StringMap PrefixMap
tm) OntologyDocument
od2
        alld :: OntologyDocument
alld = OntologyDocument -> OntologyDocument -> OntologyDocument
combineDoc OntologyDocument
od1 OntologyDocument
od2
    in (OntologyDocument
alld, OntologyDocument
newod2)

unifyDocs :: [OntologyDocument] -> [OntologyDocument]
unifyDocs :: [OntologyDocument] -> [OntologyDocument]
unifyDocs = OntologyDocument -> [OntologyDocument] -> [OntologyDocument]
unifyWith1 OntologyDocument
emptyOntologyDoc