content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  
  {- |
  Module      :  ./OWL2/Function.hs
  Copyright   :  (c) Felix Gabriel Mance
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  f.mance@jacobs-university.de
  Stability   :  provisional
  Portability :  portable
  
  Instances for some of the functions used in OWL 2
  -}
  
  module OWL2.Function where
  
  import OWL2.AS
  import Common.IRI
  import Common.Id (stringToId)
  import qualified Common.GlobalAnnotations as GA (PrefixMap)
  import OWL2.Sign
  import OWL2.Symbols
  
  import Data.List (stripPrefix)
  import Data.Maybe
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  
  {- | this class contains general functions which operate on the ontology
      document, such as prefix renaming, IRI expansion or Morphism mapping -}
  class Function a where
      function :: Action -> AMap -> a -> a
  
  data Action = Rename | Expand
      deriving (Show, Eq, Ord)
  
  type StringMap = Map.Map String String
  type MorphMap = Map.Map Entity IRI
  
  data AMap =
        StringMap StringMap
      | MorphMap MorphMap
      deriving (Show, Eq, Ord)
  
  maybeDo :: (Function a) => Action -> AMap -> Maybe a -> Maybe a
  maybeDo t mp = fmap $ function t mp
  
  getIri :: EntityType -> IRI -> Map.Map Entity IRI -> IRI
  getIri ty u = fromMaybe u . Map.lookup (mkEntity ty u)
  
  cutWith :: EntityType -> Action -> AMap -> IRI -> IRI
  cutWith ty t s anIri = cutIRI $ function t s $ mkEntity ty anIri
  
  err :: t
  err = error "operation not allowed"
  
  instance Function PrefixMap where
      function a m oldPs = case m of
          StringMap mp -> case a of
              Rename ->
                  foldl (\ ns (pre, ouri) ->
                      Map.insert (Map.findWithDefault pre pre mp) ouri ns)
                      Map.empty $ Map.toList oldPs
              Expand -> oldPs
          _ -> err
  
  instance Function GA.PrefixMap where
      function a m oldPs = case m of
          StringMap mp -> case a of
              Rename ->
                  foldl (\ ns (pre, ouri) ->
                      Map.insert (Map.findWithDefault pre pre mp) ouri ns)
                      Map.empty $ Map.toList oldPs
              Expand -> oldPs
          _ -> err
  
  instance Function IRI where
    function a m iri = case m of
      StringMap pm -> case a of
       Rename -> let pre = prefixName iri in
                iri { prefixName = Map.findWithDefault pre pre pm}
       Expand ->
        let np = prefixName iri
            lp = show $ iriPath iri
            iRi = if hasFullIRI iri then let
                    ex = np ++ ":" ++ lp
                    res = expandIRI' pm iri
                  in if elem np ["http", "https"] && not (isAbbrev iri) then -- abbreviate
                          case Map.lookup "" pm of
                            Just ep | length ep > 5 -> case stripPrefix ep ex of
                              Just rl@(_ : _) -> res
                                { prefixName = ""
                                , iriPath = stringToId rl -- todo: maybe we should keep the Id structure of iriPath iri. See #1820
                                }
                              _ -> res
                            _ -> res
                        else res
                 else if isBlankNode iri then iri
                 else let iriMap = Map.union pm predefPrefixes
                      in expandIRI' iriMap iri
        in setReservedPrefix iRi
      _ -> iri
  
  instance Function Sign where
     function t mp (Sign p1 p2 p3 p4 p5 p6 p7 p8) = case mp of
      StringMap _ ->
          Sign (Set.map (function t mp) p1)
              (Set.map (function t mp) p2)
              (Set.map (function t mp) p3)
              (Set.map (function t mp) p4)
              (Set.map (function t mp) p5)
              (Set.map (function t mp) p6)
              (Map.mapKeys (function t mp) p7)
              (function t mp p8)
      _ -> err
  
  instance Function Entity where
      function t pm (Entity _ ty ent) = case pm of
          StringMap _ -> mkEntity ty $ function t pm ent
          MorphMap m -> mkEntity ty $ getIri ty ent m
  
  instance Function Literal where
      function t pm l = case l of
          Literal lf (Typed dt) -> Literal lf $ Typed
                  $ cutWith Datatype t pm dt
          _ -> l
  
  instance Function ObjectPropertyExpression where
      function t s opr = case opr of
          ObjectProp op -> ObjectProp $ cutWith ObjectProperty t s op
          ObjectInverseOf op -> ObjectInverseOf $ function t s op
  
  instance Function DataRange where
      function t s dra = case dra of
          DataType dt ls -> DataType (cutWith Datatype t s dt)
              $ map (\ (cf, rv) -> (function t s cf, function t s rv)) ls
          DataJunction jt drl -> DataJunction jt $ map (function t s) drl
          DataComplementOf dr -> DataComplementOf $ function t s dr
          DataOneOf ll -> DataOneOf $ map (function t s) ll
  
  instance Function ClassExpression where
      function t s cle = case cle of
          Expression c -> Expression $ cutWith Class t s c
          ObjectJunction jt cel -> ObjectJunction jt $ map (function t s) cel
          ObjectComplementOf ce -> ObjectComplementOf $ function t s ce
          ObjectOneOf il -> ObjectOneOf $ map (cutWith NamedIndividual t s) il
          ObjectValuesFrom qt op ce ->
              ObjectValuesFrom qt (function t s op) $ function t s ce
          ObjectHasValue op i -> ObjectHasValue (function t s op)
              $ cutWith NamedIndividual t s i
          ObjectHasSelf op -> ObjectHasSelf $ function t s op
          ObjectCardinality (Cardinality ct i op mce) -> ObjectCardinality
              $ Cardinality ct i (function t s op) $ maybeDo t s mce
          DataValuesFrom qt dps dr -> DataValuesFrom qt
              (cutWith DataProperty t s <$> dps) $ function t s dr
          DataHasValue dp l -> DataHasValue (cutWith DataProperty t s dp)
              $ function t s l
          DataCardinality (Cardinality ct i dp mdr) -> DataCardinality
                $ Cardinality ct i (cutWith DataProperty t s dp) $ maybeDo t s mdr
  
  instance Function Annotation where
      function t s (Annotation al ap av) = Annotation (map (function t s) al)
          (cutWith AnnotationProperty t s ap) $ function t s av
  
  instance Function AnnotationValue where
      function t s av = case av of
          AnnValue anIri -> AnnValue $ function t s anIri
          AnnValLit l -> AnnValLit $ function t s l
          AnnAnInd i -> AnnAnInd $ function t s i
  
  instance Function AnnotationSubject where
      function t s av = case av of
          AnnSubIri i -> AnnSubIri $ function t s i
          AnnSubAnInd i -> AnnSubAnInd $ function t s i
  
  
  instance Function AnnotationAxiom where
      function t mp (AnnotationAssertion anno p s v) = AnnotationAssertion
          (function t mp anno)
          (function t mp p)
          (function t mp s)
          (function t mp v)
      function t mp (SubAnnotationPropertyOf anno subP supP) = SubAnnotationPropertyOf
          (function t mp anno)
          (function t mp subP)
          (function t mp supP)
      function t mp (AnnotationPropertyDomain anno p i) = AnnotationPropertyDomain
          (function t mp anno)
          (function t mp p)
          (function t mp i)
      function t mp (AnnotationPropertyRange anno p i) = AnnotationPropertyRange
          (function t mp anno)
          (function t mp p)
          (function t mp i)
  
  instance Function Axiom where
      function t mp (Declaration anns e) = Declaration (function t mp anns)
          (function t mp e)
      function t mp (ClassAxiom c) = ClassAxiom (function t mp c)
      function t mp (ObjectPropertyAxiom opAx) =
          ObjectPropertyAxiom (function t mp opAx)
      function t mp (DataPropertyAxiom d) =
          DataPropertyAxiom (function t mp d)
      function t mp  (DatatypeDefinition anns dt dr) =
          DatatypeDefinition (function t mp anns) (function t mp dt)
              (function t mp dr)
      function t mp (HasKey anns c o d) = HasKey
          (function t mp anns)
          (function t mp c)
          (function t mp <$> o)
          (function t mp <$> d)
  
      function t mp (Assertion assertion) = Assertion (function t mp assertion)   
      function t mp (AnnotationAxiom a) = AnnotationAxiom (function t mp a)
      function t mp (Rule r) = Rule (function t mp r)
      function t mp (DGAxiom anns dgName dgNodes dgEdges mainClasses) =
          DGAxiom (function t mp anns) (function t mp dgName)
              (function t mp dgNodes) (function t mp dgEdges)
              (function t mp mainClasses)
  
  instance Function ClassAxiom where
      function t mp (SubClassOf anns subClExpr supClExpr) =
          SubClassOf (function t mp anns) (function t mp subClExpr)
              (function t mp supClExpr)
  
      function t mp (EquivalentClasses anns clExprs) =
          EquivalentClasses (function t mp anns)
              (function t mp <$> clExprs)
      
      function t mp (DisjointClasses anns clExprs) =
          DisjointClasses (function t mp anns)
              (function t mp <$> clExprs)
  
      function t mp (DisjointUnion anns clIri clExprs) = 
          DisjointUnion (function t mp anns) (function t mp clIri)
              (function t mp <$> clExprs)
  
  
  instance Function SubObjectPropertyExpression where
      function t mp (SubObjPropExpr_obj e) = SubObjPropExpr_obj
          (function t mp e)
      function t mp (SubObjPropExpr_exprchain e) = SubObjPropExpr_exprchain
          (function t mp e)
  
  instance Function ObjectPropertyAxiom where
      function t mp (SubObjectPropertyOf anns subExpr supExpr) = 
          SubObjectPropertyOf (function t mp anns)
              (function t mp subExpr)
              (function t mp supExpr)
              
      function t mp (EquivalentObjectProperties anns exprs) = 
          EquivalentObjectProperties (function t mp anns)
              (function t mp <$> exprs)
  
      function t mp (DisjointObjectProperties anns exprs) = 
          DisjointObjectProperties (function t mp anns)
              (function t mp <$> exprs)
  
      function t mp (InverseObjectProperties anns expr1 expr2) = 
          InverseObjectProperties (function t mp anns)
              (function t mp expr1) (function t mp expr2)
  
      function t mp (ObjectPropertyDomain anns opExpr clExpr) = 
          ObjectPropertyDomain (function t mp anns)
              (function t mp opExpr) (function t mp clExpr)
  
      function t mp (ObjectPropertyRange anns opExpr clExpr) = 
          ObjectPropertyRange (function t mp anns)
              (function t mp opExpr) (function t mp clExpr)
              
      function t mp (FunctionalObjectProperty anns opExpr) =
          FunctionalObjectProperty (function t mp anns)
              (function t mp opExpr)
  
      function t mp (InverseFunctionalObjectProperty anns opExpr) = 
          InverseFunctionalObjectProperty (function t mp anns)
              (function t mp opExpr)
              
      function t mp (ReflexiveObjectProperty anns opExpr) =
          ReflexiveObjectProperty (function t mp anns)
              (function t mp opExpr)
              
      function t mp (IrreflexiveObjectProperty anns opExpr) =
          IrreflexiveObjectProperty (function t mp anns)
              (function t mp opExpr)
  
      function t mp (SymmetricObjectProperty anns opExpr) =
          SymmetricObjectProperty (function t mp anns)
              (function t mp opExpr)
  
      function t mp (AsymmetricObjectProperty anns opExpr) =
          AsymmetricObjectProperty (function t mp anns)
              (function t mp opExpr)
  
      function t mp (TransitiveObjectProperty anns opExpr) =
          TransitiveObjectProperty (function t mp anns)
              (function t mp opExpr)
  
  instance Function DataPropertyAxiom where
      function t mp (SubDataPropertyOf anns subD supD) =
          SubDataPropertyOf (function t mp anns)
              (function t mp subD) (function t mp supD)
      
      function t mp (EquivalentDataProperties anns dpExprs) =
          EquivalentDataProperties (function t mp anns)
              (function t mp <$> dpExprs)
              
      function t mp (DisjointDataProperties anns dpExprs) =
          DisjointDataProperties (function t mp anns)
              (function t mp dpExprs)
  
      function t mp (DataPropertyDomain anns dpExpr clExpr) =
          DataPropertyDomain (function t mp anns)
              (function t mp dpExpr) (function t mp clExpr)
      
      function t mp (DataPropertyRange anns dpExpr dr) =
          DataPropertyRange (function t mp anns)
              (function t mp dpExpr) (function t mp dr)
  
      function t mp (FunctionalDataProperty anns dpExpr) = 
          FunctionalDataProperty (function t mp anns)
              (function t mp dpExpr)
  
  instance Function Assertion where
      function t mp (SameIndividual anns is) = SameIndividual
          (function t mp anns)
          (function t mp <$> is)
      function t mp (DifferentIndividuals anns is) = DifferentIndividuals
          (function t mp anns)
          (function t mp <$> is)
      function t mp (ClassAssertion anns c i) = ClassAssertion
          (function t mp anns)
          (function t mp c)
          (function t mp i)
      function t mp (ObjectPropertyAssertion anns o s t_) = ObjectPropertyAssertion
          (function t mp anns)
          (function t mp o)
          (function t mp s)
          (function t mp t_)
      function t mp (NegativeObjectPropertyAssertion anns o s t_) = NegativeObjectPropertyAssertion
          (function t mp anns)
          (function t mp o)
          (function t mp s)
          (function t mp t_)
      function t mp (DataPropertyAssertion anns d s t_) = DataPropertyAssertion
          (function t mp anns)
          (function t mp d)
          (function t mp s)
          (function t mp t_)
      function t mp (NegativeDataPropertyAssertion anns d s t_) = NegativeDataPropertyAssertion
          (function t mp anns)
          (function t mp d)
          (function t mp s)
          (function t mp t_)
  
  
  instance (Function a) => Function [a] where
      function t mp l = function t mp <$> l
  
  instance (Function a) => Function (Maybe a) where
      function _ _ Nothing = Nothing
      function t mp (Just l) = Just (function t mp l)
  
  instance Function Rule where
      function t mp (DLSafeRule anns b h) = DLSafeRule
          (function t mp anns)
          (function t mp b)
          (function t mp h)
      function t mp (DGRule anns b h) = DGRule
          (function t mp anns)
          (function t mp b)
          (function t mp h)
  
  instance Function DataArg where
      function t mp (DArg l) = DArg (function t mp l)
      function t mp (DVar v) = DVar (function t mp v)
  
  instance Function IndividualArg where
      function t mp (IArg i) = IArg (function t mp i)
      function t mp (IVar v) = IVar (function t mp v)
  
  instance Function UnknownArg   where
      function t mp (IndividualArg i) = IndividualArg (function t mp i)
      function t mp (DataArg d) = DataArg (function t mp d)
      function t mp (Variable v) = Variable (function t mp v)
      
  instance Function Atom where
      function t mp (ClassAtom c arg) = ClassAtom
          (function t mp c)
          (function t mp arg)
      function t mp (DataRangeAtom d arg) = DataRangeAtom
          (function t mp d)
          (function t mp arg)
      function t mp (ObjectPropertyAtom oexpr arg1 arg2) = ObjectPropertyAtom
          (function t mp oexpr)
          (function t mp arg1)
          (function t mp arg2)
      function t mp (DataPropertyAtom d arg1 arg2) = DataPropertyAtom
          (function t mp d)
          (function t mp arg1)
          (function t mp arg2)
      function t mp (BuiltInAtom i args) = BuiltInAtom
          (function t mp i)
          (function t mp <$> args)
      function t mp (SameIndividualAtom arg1 arg2) = SameIndividualAtom
          (function t mp arg1)
          (function t mp arg2)
      function t mp (DifferentIndividualsAtom arg1 arg2) = DifferentIndividualsAtom
          (function t mp arg1)
          (function t mp arg2)
      function t mp (UnknownUnaryAtom i arg) = UnknownUnaryAtom
          (function t mp i)
          (function t mp arg)
      function t mp (UnknownBinaryAtom i arg1 arg2) = UnknownBinaryAtom
          (function t mp i)
          (function t mp arg1)
          (function t mp arg2)
      
  
  instance Function DGAtom where
      function t mp (DGClassAtom c arg) = DGClassAtom
          (function t mp c)
          (function t mp arg)
      function t mp (DGObjectPropertyAtom e a1 a2) = DGObjectPropertyAtom
          (function t mp e)
          (function t mp a1)
          (function t mp a2)
  
  instance Function DGEdgeAssertion where
      function t mp (DGEdgeAssertion o v1 v2) = DGEdgeAssertion
          (function t mp o)
          (function t mp v1)
          (function t mp v2)
  
  instance Function DGNodeAssertion where
      function t mp (DGNodeAssertion c node) = DGNodeAssertion
          (function t mp c)
          (function t mp node)
  
  
  instance Function Ontology where
      function t mp (Ontology n version imp anns ax) = Ontology
          (function t mp n)
          (function t mp version)
          (function t mp imp)
          (function t mp anns)
          (function t mp ax)
  
  instance Function PrefixDeclaration where
      function t mp (PrefixDeclaration n i) = PrefixDeclaration
          n
          (function t mp i)
  
  instance Function OntologyDocument where
    function t mp (OntologyDocument m pm onto) =
        OntologyDocument m (function t mp pm) (function t mp onto)
  
  instance Function RawSymb where
    function t mp rs = case rs of
       ASymbol e -> ASymbol $ function t mp e
       AnUri i -> AnUri $ function t mp i
       p -> p
  