{- |
Module      :  ./NeSyPatterns/Taxonomy.hs
Description :  Taxonomy extraction for NeSyPatterns
Copyright   :  (c) Dominik Luecke, Uni Bremen 2008
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  luecke@informatik.uni-bremen.de
Stability   :  provisional
Portability :  portabl

Taxonomy extraction for NeSyPatterns
-}

module NeSyPatterns.Taxonomy ( nesy2Tax ) where

import NeSyPatterns.Sign

import Common.AS_Annotation
import Common.Result
import Taxonomy.MMiSSOntology
import Common.Taxonomy

import qualified Data.Foldable as Fold
import qualified Data.Relation as Rel

import qualified Data.Set as Set

-- | Derivation of an Taxonomy for NeSyPatterns
nesy2Tax :: TaxoGraphKind
         -> MMiSSOntology
         -> Sign -> [Named ()]
         -> Result MMiSSOntology
nesy2Tax :: TaxoGraphKind
-> MMiSSOntology -> Sign -> [Named ()] -> Result MMiSSOntology
nesy2Tax gk :: TaxoGraphKind
gk inOnto :: MMiSSOntology
inOnto sig :: Sign
sig _ = case TaxoGraphKind
gk of
  KSubsort -> String -> Result MMiSSOntology
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Dear user, this logic is single sorted, sorry!"
  KConcept -> MMiSSOntology
-> Relation ResolvedNode ResolvedNode
-> Set ResolvedNode
-> Result MMiSSOntology
makeMiss MMiSSOntology
inOnto (Sign -> Relation ResolvedNode ResolvedNode
edges Sign
sig) (Sign -> Set ResolvedNode
nodes Sign
sig)


-- | Generation of a MissOntology
makeMiss :: MMiSSOntology
         -> Rel.Relation ResolvedNode ResolvedNode
         -> Set.Set ResolvedNode
         -> Result MMiSSOntology
makeMiss :: MMiSSOntology
-> Relation ResolvedNode ResolvedNode
-> Set ResolvedNode
-> Result MMiSSOntology
makeMiss o :: MMiSSOntology
o relation :: Relation ResolvedNode ResolvedNode
relation = let 
    superClasses :: ResolvedNode -> [String]
superClasses y :: ResolvedNode
y = (ResolvedNode -> String) -> [ResolvedNode] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (ResolvedNode -> Doc) -> ResolvedNode -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedNode -> Doc
forall a. Pretty a => a -> Doc
pretty) ([ResolvedNode] -> [String])
-> (Relation ResolvedNode ResolvedNode -> [ResolvedNode])
-> Relation ResolvedNode ResolvedNode
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ResolvedNode -> [ResolvedNode]
forall a. Set a -> [a]
Set.toList (Set ResolvedNode -> [ResolvedNode])
-> (Relation ResolvedNode ResolvedNode -> Set ResolvedNode)
-> Relation ResolvedNode ResolvedNode
-> [ResolvedNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolvedNode
-> Relation ResolvedNode ResolvedNode -> Set ResolvedNode
forall b a. Ord b => b -> Relation a b -> Set a
Rel.lookupRan ResolvedNode
y (Relation ResolvedNode ResolvedNode -> [String])
-> Relation ResolvedNode ResolvedNode -> [String]
forall a b. (a -> b) -> a -> b
$ Relation ResolvedNode ResolvedNode
relation
  in (MMiSSOntology -> ResolvedNode -> Result MMiSSOntology)
-> MMiSSOntology -> Set ResolvedNode -> Result MMiSSOntology
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Fold.foldlM (\o' :: MMiSSOntology
o' y :: ResolvedNode
y -> WithError MMiSSOntology -> Result MMiSSOntology
forall (m :: * -> *) a. MonadFail m => WithError a -> m a
fromWithError (WithError MMiSSOntology -> Result MMiSSOntology)
-> WithError MMiSSOntology -> Result MMiSSOntology
forall a b. (a -> b) -> a -> b
$ MMiSSOntology
-> String
-> String
-> [String]
-> Maybe ClassType
-> WithError MMiSSOntology
insertClass MMiSSOntology
o' (Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ ResolvedNode -> Doc
forall a. Pretty a => a -> Doc
pretty ResolvedNode
y) "" (ResolvedNode -> [String]
superClasses ResolvedNode
y) Maybe ClassType
forall a. Maybe a
Nothing) MMiSSOntology
o