{- |
Module      :  ./CSMOF/StatAna.hs
Description :  Static CSMOF analysis
Copyright   :  (c) Daniel Calegari Universidad de la Republica, Uruguay 2013
License     :  GPLv2 or higher, see LICENSE.txt
Maintainer  :  dcalegar@fing.edu.uy
Stability   :  provisional
Portability :  portable
-}

module CSMOF.StatAna where

import CSMOF.As
import CSMOF.Sign

import Common.Result
import Common.GlobalAnnotations
import Common.ExtSign
import Common.AS_Annotation

import qualified Common.Lib.Rel as Rel
import qualified Data.Set as Set
import qualified Data.Map as Map


basicAna :: (Metamodel, Sign, GlobalAnnos) -> Result (Metamodel, ExtSign Sign (), [Named Sen])
basicAna :: (Metamodel, Sign, GlobalAnnos)
-> Result (Metamodel, ExtSign Sign (), [Named Sen])
basicAna (meta :: Metamodel
meta, _, _) = (Metamodel, ExtSign Sign (), [Named Sen])
-> Result (Metamodel, ExtSign Sign (), [Named Sen])
forall (m :: * -> *) a. Monad m => a -> m a
return (Metamodel
meta, Sign -> ExtSign Sign ()
forall sign symbol. sign -> ExtSign sign symbol
mkExtSign (Metamodel -> Sign
buildSignature Metamodel
meta), Metamodel -> [Named Sen]
buildSentences Metamodel
meta)


data TypeInfo = TypeInfo { TypeInfo -> Set TypeClass
typesI :: Set.Set TypeClass
                         , TypeInfo -> Rel TypeClass
typRelI :: Rel.Rel TypeClass
                         , TypeInfo -> Set TypeClass
absTypes :: Set.Set TypeClass }

data PropInfo = PropInfo { PropInfo -> Set Role
rolInfo :: Set.Set Role
                         , PropInfo -> Set PropertyT
propInfo :: Set.Set PropertyT }


buildSignature :: Metamodel -> Sign
buildSignature :: Metamodel -> Sign
buildSignature m :: Metamodel
m =
  let typesInfo :: (TypeInfo, PropInfo)
typesInfo = Metamodel -> (TypeInfo, PropInfo)
buildSignatureInfo Metamodel
m
  in Sign :: Set TypeClass
-> Rel TypeClass
-> Set TypeClass
-> Set Role
-> Set PropertyT
-> Map Role TypeClass
-> Set LinkT
-> Sign
Sign { types :: Set TypeClass
types = TypeInfo -> Set TypeClass
typesI ((TypeInfo, PropInfo) -> TypeInfo
forall a b. (a, b) -> a
fst (TypeInfo, PropInfo)
typesInfo)
          , typeRel :: Rel TypeClass
typeRel = TypeInfo -> Rel TypeClass
typRelI ((TypeInfo, PropInfo) -> TypeInfo
forall a b. (a, b) -> a
fst (TypeInfo, PropInfo)
typesInfo)
          , abstractClasses :: Set TypeClass
abstractClasses = TypeInfo -> Set TypeClass
absTypes ((TypeInfo, PropInfo) -> TypeInfo
forall a b. (a, b) -> a
fst (TypeInfo, PropInfo)
typesInfo)
          , roles :: Set Role
roles = PropInfo -> Set Role
rolInfo ((TypeInfo, PropInfo) -> PropInfo
forall a b. (a, b) -> b
snd (TypeInfo, PropInfo)
typesInfo)
          , properties :: Set PropertyT
properties = PropInfo -> Set PropertyT
propInfo ((TypeInfo, PropInfo) -> PropInfo
forall a b. (a, b) -> b
snd (TypeInfo, PropInfo)
typesInfo)
          , instances :: Map Role TypeClass
instances = Metamodel -> Map Role TypeClass
buildInstances Metamodel
m
          , links :: Set LinkT
links = Metamodel -> Set LinkT
buildLinks Metamodel
m
          }

emptyPropType :: (TypeInfo, PropInfo)
emptyPropType :: (TypeInfo, PropInfo)
emptyPropType = (Set TypeClass -> Rel TypeClass -> Set TypeClass -> TypeInfo
TypeInfo Set TypeClass
forall a. Set a
Set.empty Rel TypeClass
forall a. Rel a
Rel.empty Set TypeClass
forall a. Set a
Set.empty, Set Role -> Set PropertyT -> PropInfo
PropInfo Set Role
forall a. Set a
Set.empty Set PropertyT
forall a. Set a
Set.empty)


buildSignatureInfo :: Metamodel -> (TypeInfo, PropInfo)
buildSignatureInfo :: Metamodel -> (TypeInfo, PropInfo)
buildSignatureInfo = (NamedElement -> (TypeInfo, PropInfo) -> (TypeInfo, PropInfo))
-> (TypeInfo, PropInfo) -> [NamedElement] -> (TypeInfo, PropInfo)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamedElement -> (TypeInfo, PropInfo) -> (TypeInfo, PropInfo)
buildInfo (TypeInfo, PropInfo)
emptyPropType ([NamedElement] -> (TypeInfo, PropInfo))
-> (Metamodel -> [NamedElement])
-> Metamodel
-> (TypeInfo, PropInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metamodel -> [NamedElement]
element

buildInfo :: NamedElement -> (TypeInfo, PropInfo) -> (TypeInfo, PropInfo)
buildInfo :: NamedElement -> (TypeInfo, PropInfo) -> (TypeInfo, PropInfo)
buildInfo (NamedElement el :: Role
el _ (TType (Type _ (DDataType _)))) (ti :: TypeInfo
ti, pin :: PropInfo
pin) =
  (Set TypeClass -> Rel TypeClass -> Set TypeClass -> TypeInfo
TypeInfo (TypeClass -> Set TypeClass -> Set TypeClass
forall a. Ord a => a -> Set a -> Set a
Set.insert (Role -> TypeKind -> TypeClass
TypeClass Role
el TypeKind
DataTypeKind) (TypeInfo -> Set TypeClass
typesI TypeInfo
ti)) (TypeInfo -> Rel TypeClass
typRelI TypeInfo
ti) (TypeInfo -> Set TypeClass
absTypes TypeInfo
ti), PropInfo
pin)
buildInfo (NamedElement el :: Role
el _ (TType (Type _ (DClass (Class _ abst :: Bool
abst supC :: [Class]
supC _))))) (ti :: TypeInfo
ti, pin :: PropInfo
pin) =
  let classT :: TypeClass
classT = Role -> TypeKind -> TypeClass
TypeClass Role
el TypeKind
ClassKind
      rels :: Rel TypeClass
rels = TypeClass -> [Class] -> Rel TypeClass -> Rel TypeClass
addSuperClasses TypeClass
classT [Class]
supC (TypeInfo -> Rel TypeClass
typRelI TypeInfo
ti)
  in if Bool
abst then
     (Set TypeClass -> Rel TypeClass -> Set TypeClass -> TypeInfo
TypeInfo (TypeClass -> Set TypeClass -> Set TypeClass
forall a. Ord a => a -> Set a -> Set a
Set.insert TypeClass
classT (TypeInfo -> Set TypeClass
typesI TypeInfo
ti)) Rel TypeClass
rels
               (TypeClass -> Set TypeClass -> Set TypeClass
forall a. Ord a => a -> Set a -> Set a
Set.insert TypeClass
classT (TypeInfo -> Set TypeClass
absTypes TypeInfo
ti)), PropInfo
pin)
     else (Set TypeClass -> Rel TypeClass -> Set TypeClass -> TypeInfo
TypeInfo (TypeClass -> Set TypeClass -> Set TypeClass
forall a. Ord a => a -> Set a -> Set a
Set.insert TypeClass
classT (TypeInfo -> Set TypeClass
typesI TypeInfo
ti)) Rel TypeClass
rels (TypeInfo -> Set TypeClass
absTypes TypeInfo
ti), PropInfo
pin)
buildInfo (NamedElement el :: Role
el _ (TTypedElement (TypedElement _ ty :: Type
ty (Property _ _ opp :: Maybe Property
opp cla :: Class
cla)))) (ti :: TypeInfo
ti, pin :: PropInfo
pin) =
  let role :: Set Role
role = Role -> Set Role -> Set Role
forall a. Ord a => a -> Set a -> Set a
Set.insert (PropertyT -> Role
targetRole PropertyT
prop) (Role -> Set Role -> Set Role
forall a. Ord a => a -> Set a -> Set a
Set.insert (PropertyT -> Role
sourceRole PropertyT
prop) (PropInfo -> Set Role
rolInfo PropInfo
pin))
      prop :: PropertyT
prop = Role -> Type -> Class -> Maybe Property -> PropertyT
createProperty Role
el Type
ty Class
cla Maybe Property
opp
  in
   (TypeInfo
ti, Set Role -> Set PropertyT -> PropInfo
PropInfo Set Role
role (PropertyT -> Set PropertyT -> Set PropertyT
forall a. Ord a => a -> Set a -> Set a
Set.insert PropertyT
prop (PropInfo -> Set PropertyT
propInfo PropInfo
pin)))


addSuperClasses :: TypeClass -> [Class] -> Rel.Rel TypeClass -> Rel.Rel TypeClass
addSuperClasses :: TypeClass -> [Class] -> Rel TypeClass -> Rel TypeClass
addSuperClasses tc :: TypeClass
tc = (Rel TypeClass -> [Class] -> Rel TypeClass)
-> [Class] -> Rel TypeClass -> Rel TypeClass
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Rel TypeClass -> [Class] -> Rel TypeClass)
 -> [Class] -> Rel TypeClass -> Rel TypeClass)
-> (Rel TypeClass -> [Class] -> Rel TypeClass)
-> [Class]
-> Rel TypeClass
-> Rel TypeClass
forall a b. (a -> b) -> a -> b
$ (Class -> Rel TypeClass -> Rel TypeClass)
-> Rel TypeClass -> [Class] -> Rel TypeClass
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeClass -> TypeClass -> Rel TypeClass -> Rel TypeClass
forall a. Ord a => a -> a -> Rel a -> Rel a
Rel.insertPair TypeClass
tc (TypeClass -> Rel TypeClass -> Rel TypeClass)
-> (Class -> TypeClass) -> Class -> Rel TypeClass -> Rel TypeClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> TypeClass
toTypeClass)

toTypeClass :: Class -> TypeClass
toTypeClass :: Class -> TypeClass
toTypeClass c :: Class
c = Role -> TypeKind -> TypeClass
TypeClass (NamedElement -> Role
namedElementName (Type -> NamedElement
typeSuper (Class -> Type
classSuperType Class
c))) TypeKind
ClassKind


buildInstances :: Metamodel -> Map.Map String TypeClass
buildInstances :: Metamodel -> Map Role TypeClass
buildInstances m :: Metamodel
m =
  let models :: [Model]
models = Metamodel -> [Model]
model Metamodel
m
  in case [Model]
models of
       [] -> Map Role TypeClass
forall k a. Map k a
Map.empty
       -- There is assumed that there is only one model to process, the thers are discarded
       mo :: Model
mo : _ -> (Object -> Map Role TypeClass -> Map Role TypeClass)
-> Map Role TypeClass -> [Object] -> Map Role TypeClass
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Object -> Map Role TypeClass -> Map Role TypeClass
createInstanceFromObject Map Role TypeClass
forall k a. Map k a
Map.empty (Model -> [Object]
object Model
mo)

createInstanceFromObject :: Object -> Map.Map String TypeClass -> Map.Map String TypeClass
createInstanceFromObject :: Object -> Map Role TypeClass -> Map Role TypeClass
createInstanceFromObject ob :: Object
ob mapp :: Map Role TypeClass
mapp =
  let targetClassType :: TypeKind
targetClassType =
        case Type -> DataTypeOrClass
typeSubClasses (Object -> Type
objectType Object
ob) of
          DDataType _ -> TypeKind
DataTypeKind
          DClass _ -> TypeKind
ClassKind
  in Role -> TypeClass -> Map Role TypeClass -> Map Role TypeClass
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Object -> Role
objectName Object
ob) (Role -> TypeKind -> TypeClass
TypeClass (NamedElement -> Role
namedElementName (Type -> NamedElement
typeSuper (Object -> Type
objectType Object
ob))) TypeKind
targetClassType) Map Role TypeClass
mapp


buildLinks :: Metamodel -> Set.Set LinkT
buildLinks :: Metamodel -> Set LinkT
buildLinks m :: Metamodel
m =
  let models :: [Model]
models = Metamodel -> [Model]
model Metamodel
m
  in case [Model]
models of
       [] -> Set LinkT
forall a. Set a
Set.empty
       -- There is assumed that there is only one model to process, the thers are discarded
       mo :: Model
mo : _ -> (Link -> Set LinkT -> Set LinkT)
-> Set LinkT -> [Link] -> Set LinkT
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Link -> Set LinkT -> Set LinkT
createLinksFromLinks Set LinkT
forall a. Set a
Set.empty (Model -> [Link]
link Model
mo)

createLinksFromLinks :: Link -> Set.Set LinkT -> Set.Set LinkT
createLinksFromLinks :: Link -> Set LinkT -> Set LinkT
createLinksFromLinks li :: Link
li linkk :: Set LinkT
linkk =
  let nam :: Role
nam = NamedElement -> Role
namedElementName (TypedElement -> NamedElement
typedElementSuper (Property -> TypedElement
propertySuper (Link -> Property
linkType Link
li)))
      ty :: Type
ty = TypedElement -> Type
typedElementType (Property -> TypedElement
propertySuper (Link -> Property
linkType Link
li))
      cla :: Class
cla = Property -> Class
propertyClass (Link -> Property
linkType Link
li)
      opp :: Maybe Property
opp = Property -> Maybe Property
opposite (Link -> Property
linkType Link
li)
  in
   LinkT -> Set LinkT -> Set LinkT
forall a. Ord a => a -> Set a -> Set a
Set.insert (Role -> Role -> PropertyT -> LinkT
LinkT (Object -> Role
objectName (Link -> Object
source Link
li)) (Object -> Role
objectName (Link -> Object
target Link
li)) (Role -> Type -> Class -> Maybe Property -> PropertyT
createProperty Role
nam Type
ty Class
cla Maybe Property
opp)) Set LinkT
linkk


createProperty :: String -> Type -> Class -> Maybe Property -> PropertyT
createProperty :: Role -> Type -> Class -> Maybe Property -> PropertyT
createProperty el :: Role
el ty :: Type
ty cla :: Class
cla opp :: Maybe Property
opp =
  let sourceClassName :: Role
sourceClassName = NamedElement -> Role
namedElementName (Type -> NamedElement
typeSuper (Class -> Type
classSuperType Class
cla))
      targetClassName :: Role
targetClassName = NamedElement -> Role
namedElementName (Type -> NamedElement
typeSuper Type
ty)
      targetClassType :: TypeKind
targetClassType =
        case Type -> DataTypeOrClass
typeSubClasses Type
ty of
          DDataType _ -> TypeKind
DataTypeKind
          DClass _ -> TypeKind
ClassKind
  in
   case Maybe Property
opp of
     Nothing -> Role -> TypeClass -> Role -> TypeClass -> PropertyT
PropertyT "_"
                (Role -> TypeKind -> TypeClass
TypeClass Role
sourceClassName TypeKind
ClassKind)
                Role
el
                (Role -> TypeKind -> TypeClass
TypeClass Role
targetClassName TypeKind
targetClassType)
     Just p :: Property
p -> Role -> TypeClass -> Role -> TypeClass -> PropertyT
PropertyT (NamedElement -> Role
namedElementName (TypedElement -> NamedElement
typedElementSuper (Property -> TypedElement
propertySuper Property
p)))
                (Role -> TypeKind -> TypeClass
TypeClass Role
sourceClassName TypeKind
ClassKind)
                Role
el
                (Role -> TypeKind -> TypeClass
TypeClass Role
targetClassName TypeKind
targetClassType)


buildSentences :: Metamodel -> [Named Sen]
buildSentences :: Metamodel -> [Named Sen]
buildSentences = (NamedElement -> [Named Sen] -> [Named Sen])
-> [Named Sen] -> [NamedElement] -> [Named Sen]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamedElement -> [Named Sen] -> [Named Sen]
buildSen [] ([NamedElement] -> [Named Sen])
-> (Metamodel -> [NamedElement]) -> Metamodel -> [Named Sen]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metamodel -> [NamedElement]
element


buildSen :: NamedElement -> [Named Sen] -> [Named Sen]
buildSen :: NamedElement -> [Named Sen] -> [Named Sen]
buildSen (NamedElement _ _ (TType _)) lis :: [Named Sen]
lis = [Named Sen]
lis
buildSen (NamedElement el :: Role
el _ (TTypedElement (TypedElement _ _
                                                      (Property _ (MultiplicityElement low :: Integer
low upp :: Integer
upp _) _ cla :: Class
cla)))) lis :: [Named Sen]
lis =
  let clas :: TypeClass
clas = Role -> TypeKind -> TypeClass
TypeClass (NamedElement -> Role
namedElementName (Type -> NamedElement
typeSuper (Class -> Type
classSuperType Class
cla))) TypeKind
ClassKind
  in
   if Integer
low Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
upp
   then Role -> Sen -> Named Sen
forall a s. a -> s -> SenAttr s a
makeNamed "" (MultConstr -> Integer -> ConstraintType -> Sen
Sen (TypeClass -> Role -> MultConstr
MultConstr TypeClass
clas Role
el) Integer
low ConstraintType
EQUAL) Named Sen -> [Named Sen] -> [Named Sen]
forall a. a -> [a] -> [a]
: [Named Sen]
lis
   else if Integer
upp Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= -1 then Role -> Sen -> Named Sen
forall a s. a -> s -> SenAttr s a
makeNamed "" (MultConstr -> Integer -> ConstraintType -> Sen
Sen (TypeClass -> Role -> MultConstr
MultConstr TypeClass
clas Role
el) Integer
upp ConstraintType
LEQ) Named Sen -> [Named Sen] -> [Named Sen]
forall a. a -> [a] -> [a]
:
          if Integer
low Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
             Role -> Sen -> Named Sen
forall a s. a -> s -> SenAttr s a
makeNamed "" (MultConstr -> Integer -> ConstraintType -> Sen
Sen (TypeClass -> Role -> MultConstr
MultConstr TypeClass
clas Role
el) Integer
low ConstraintType
GEQ) Named Sen -> [Named Sen] -> [Named Sen]
forall a. a -> [a] -> [a]
: [Named Sen]
lis
          else [Named Sen]
lis
        else if Integer
low Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then
               Role -> Sen -> Named Sen
forall a s. a -> s -> SenAttr s a
makeNamed "" (MultConstr -> Integer -> ConstraintType -> Sen
Sen (TypeClass -> Role -> MultConstr
MultConstr TypeClass
clas Role
el) Integer
low ConstraintType
GEQ) Named Sen -> [Named Sen] -> [Named Sen]
forall a. a -> [a] -> [a]
: [Named Sen]
lis
             else [Named Sen]
lis