{- |

Module : $Header$

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 (meta, _, _) = return (meta, mkExtSign (buildSignature meta), buildSentences meta)

data TypeInfo = TypeInfo { typesI :: Set.Set TypeClass

, typRelI :: Rel.Rel TypeClass

, absTypes :: Set.Set TypeClass }

data PropInfo = PropInfo { rolInfo :: Set.Set Role

, propInfo :: Set.Set PropertyT }

buildSignature :: Metamodel -> Sign

buildSignature m =

let typesInfo = buildSignatureInfo m

in Sign { types = typesI (fst typesInfo)

, typeRel = typRelI (fst typesInfo)

, abstractClasses = absTypes (fst typesInfo)

, roles = rolInfo (snd typesInfo)

, properties = propInfo (snd typesInfo)

, instances = buildInstances m

, links = buildLinks m

}

emptyPropType :: (TypeInfo, PropInfo)

emptyPropType = (TypeInfo Set.empty Rel.empty Set.empty, PropInfo Set.empty Set.empty)

buildSignatureInfo :: Metamodel -> (TypeInfo, PropInfo)

buildSignatureInfo = foldr buildInfo emptyPropType . element

buildInfo :: NamedElement -> (TypeInfo, PropInfo) -> (TypeInfo, PropInfo)

buildInfo (NamedElement el _ (TType (Type _ (DDataType _)))) (ti, pin) =

(TypeInfo (Set.insert (TypeClass el DataTypeKind) (typesI ti)) (typRelI ti) (absTypes ti), pin)

buildInfo (NamedElement el _ (TType (Type _ (DClass (Class _ abst supC _))))) (ti, pin) =

let classT = TypeClass el ClassKind

rels = addSuperClasses classT supC (typRelI ti)

in if abst then

(TypeInfo (Set.insert classT (typesI ti)) rels

(Set.insert classT (absTypes ti)), pin)

else (TypeInfo (Set.insert classT (typesI ti)) rels (absTypes ti), pin)

buildInfo (NamedElement el _ (TTypedElement (TypedElement _ ty (Property _ _ opp cla)))) (ti, pin) =

let role = Set.insert (targetRole prop) (Set.insert (sourceRole prop) (rolInfo pin))

prop = createProperty el ty cla opp

in

(ti, PropInfo role (Set.insert prop (propInfo pin)))

addSuperClasses :: TypeClass -> [Class] -> Rel.Rel TypeClass -> Rel.Rel TypeClass

addSuperClasses tc = flip $ foldr (Rel.insertPair tc . toTypeClass)

toTypeClass :: Class -> TypeClass

toTypeClass c = TypeClass (namedElementName (typeSuper (classSuperType c))) ClassKind

buildInstances :: Metamodel -> Map.Map String TypeClass

buildInstances m =

let models = model m

in case models of

[] -> Map.empty

-- There is assumed that there is only one model to process, the thers are discarded

mo : _ -> foldr createInstanceFromObject Map.empty (object mo)

createInstanceFromObject :: Object -> Map.Map String TypeClass -> Map.Map String TypeClass

createInstanceFromObject ob mapp =

let targetClassType =

case typeSubClasses (objectType ob) of

DDataType _ -> DataTypeKind

DClass _ -> ClassKind

in Map.insert (objectName ob) (TypeClass (namedElementName (typeSuper (objectType ob))) targetClassType) mapp

buildLinks :: Metamodel -> Set.Set LinkT

buildLinks m =

let models = model m

in case models of

[] -> Set.empty

-- There is assumed that there is only one model to process, the thers are discarded

mo : _ -> foldr createLinksFromLinks Set.empty (link mo)

createLinksFromLinks :: Link -> Set.Set LinkT -> Set.Set LinkT

createLinksFromLinks li linkk =

let nam = namedElementName (typedElementSuper (propertySuper (linkType li)))

ty = typedElementType (propertySuper (linkType li))

cla = propertyClass (linkType li)

opp = opposite (linkType li)

in

Set.insert (LinkT (objectName (source li)) (objectName (target li)) (createProperty nam ty cla opp)) linkk

createProperty :: String -> Type -> Class -> Maybe Property -> PropertyT

createProperty el ty cla opp =

let sourceClassName = namedElementName (typeSuper (classSuperType cla))

targetClassName = namedElementName (typeSuper ty)

targetClassType =

case typeSubClasses ty of

DDataType _ -> DataTypeKind

DClass _ -> ClassKind

in

case opp of

Nothing -> PropertyT "_"

(TypeClass sourceClassName ClassKind)

el

(TypeClass targetClassName targetClassType)

Just p -> PropertyT (namedElementName (typedElementSuper (propertySuper p)))

(TypeClass sourceClassName ClassKind)

el

(TypeClass targetClassName targetClassType)

buildSentences :: Metamodel -> [Named Sen]

buildSentences = foldr buildSen [] . element

buildSen :: NamedElement -> [Named Sen] -> [Named Sen]

buildSen (NamedElement _ _ (TType _)) lis = lis

buildSen (NamedElement el _ (TTypedElement (TypedElement _ _

(Property _ (MultiplicityElement low upp _) _ cla)))) lis =

let clas = TypeClass (namedElementName (typeSuper (classSuperType cla))) ClassKind

in

if low == upp

then makeNamed "" (Sen (MultConstr clas el) low EQUAL) : lis

else if upp /= -1 then makeNamed "" (Sen (MultConstr clas el) upp LEQ) :

if low > 0 then

makeNamed "" (Sen (MultConstr clas el) low GEQ) : lis

else lis

else if low > 0 then

makeNamed "" (Sen (MultConstr clas el) low GEQ) : lis

else lis