As.hs revision f2c638409c8d870e5ad6edf2b064f959b0b86aa3
{- |
Module : $Header$
Description : abstract CSMOF syntax
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.As where
import qualified Data.Set as Set
-- Simplified MOF Metamodel
data Metamodel = Metamodel
{ metamodelName :: String
, element :: Set.Set NamedElement
, model :: Set.Set Model
} deriving (Eq, Ord)
instance Show Metamodel where
show (Metamodel nam ele mod) =
"metamodel " ++ nam ++ " { \n"
++ Set.fold ((++). show) "" ele
++ "}\n\n"
++ Set.fold ((++). show) "" mod
data NamedElement = NamedElement
{ namedElementName :: String
, namedElementOwner :: Metamodel
, namedElementSubClasses :: TypeOrTypedElement
} deriving (Eq, Ord)
instance Show NamedElement where
show (NamedElement nam met nes) = show nes
data TypeOrTypedElement = TType { getType :: Type }
| TTypedElement { getTypeElement :: TypedElement }
deriving (Eq, Ord)
instance Show TypeOrTypedElement where
show (TType typ) = show typ
-- Do not show properties at top level but inside classes
show (TTypedElement typ) = ""
-- When going downside-up, we can sort the auxiliary class TypeOrTypedElement and make super of type NamedElement
data Type = Type { typeSuper :: NamedElement
, typeSubClasses :: DataTypeOrClass
} deriving (Eq, Ord)
instance Show Type where
show (Type sup sub) = show sub
data DataTypeOrClass = DDataType { getDataType :: DataType }
| DClass { getClass :: Class }
deriving (Eq, Ord)
instance Show DataTypeOrClass where
show (DDataType dat) = show dat
show (DClass cla) = show cla
-- When going downside-up, we can sort the auxiliary class DataTypeOrClass and make super of type Type
data DataType = DataType { classSuper :: Type } deriving (Eq, Ord)
instance Show DataType where
show (DataType sup) = "\t" ++ "datatype " ++ namedElementName (typeSuper sup) ++ "\n\n"
-- When going downside-up, we can sort the auxiliary class DataTypeOrClass and make super of type Type
data Class = Class
{ classSuperType :: Type
, isAbstract :: Bool
, superClass :: Set.Set Class
, ownedAttribute :: Set.Set Property
} deriving (Eq, Ord)
instance Show Class where
show (Class sup isa supC own) =
"\t"
++ (case isa of
True -> "abstract class "
False -> "class ")
++ namedElementName (typeSuper sup) ++ " "
++ (case Set.null supC of
True -> "{ \n"
False -> "extends"
++ Set.fold ( (++) . (" " ++). namedElementName . typeSuper . classSuperType) "" supC
++ " { \n")
++ Set.fold ((++). show) "" own
++ "\t } \n\n"
-- When going downside-up, we can sort the auxiliary class TypeOrTypedElement and make super of type NamedElement
data TypedElement = TypedElement
{ typedElementSuper :: NamedElement
, typedElementType :: Type
, typedElementSubClasses :: Property
} deriving (Eq, Ord)
instance Show TypedElement where
show (TypedElement sup typ sub) = show sub
data Property = Property
{ propertySuper ::TypedElement
, multiplicityElement :: MultiplicityElement
, opposite :: Maybe Property
, propertyClass :: Class
} deriving (Eq, Ord)
instance Show Property where
show (Property sup mul opp pro) =
"\t\t"
++ "property " ++ namedElementName (typedElementSuper sup)
++ show mul
++ " : " ++ namedElementName (typeSuper (classSuperType pro))
++ (case opp of
Just n -> " oppositeOf " ++ namedElementName (typedElementSuper (propertySuper n))
Nothing -> "")
++ "\n"
data MultiplicityElement = MultiplicityElement
{ lower :: Integer
, upper :: Integer
, multiplicityElementSubClasses :: Property
} deriving (Eq, Ord)
instance Show MultiplicityElement where
show (MultiplicityElement low upp mes) =
" [" ++ show low ++ ","
++ (case upp of
-1 -> "*"
otherwise -> show upp)
++ "]"
-- Model part of CSMOF
data Model = Model
{ modelName :: String
, object :: Set.Set Object
, link :: Set.Set Link
, modelType :: Metamodel
} deriving (Eq, Ord)
instance Show Model where
show (Model mon obj lin mod) =
"model " ++ mon
++ " conformsTo " ++ metamodelName mod ++ " { \n"
++ Set.fold ((++). show) "" obj
++ Set.fold ((++). show) "" lin
++ "} \n"
data Object = Object
{ objectName :: String
, objectType :: Type
, objectOwner :: Model
} deriving (Eq, Ord)
instance Show Object where
show (Object on ot oo) =
"\t object " ++ on
++ " : " ++ namedElementName (typeSuper ot)
++ "\n"
data Link = Link
{ linkType :: Property
, source :: Object
, target :: Object
, linkOwner :: Model
} deriving (Eq, Ord)
instance Show Link where
show (Link lt sou tar ow) = "link"
-- "\t link " ++ namedElementName (typedElementSuper (propertySuper lt))
-- ++ "(" ++ objectName sou ++ "," ++ objectName tar ++ ") \n"
----------------------------------------------------------
main :: IO ()
main = let metamodel = Metamodel{ metamodelName = "ClassMetamodel"
, element = Set.insert namedElement_String
(Set.insert namedElement_UMLModelElement
(Set.insert namedElement_Attribute
(Set.insert namedElement_Package
(Set.insert namedElement_Classifier
(Set.insert namedElement_Class
(Set.insert namedElement_PrimitiveDataType
(Set.insert namedElement_Pkind
(Set.insert namedElement_Pname
(Set.insert namedElement_Pnamespace
(Set.insert namedElement_Pelements
(Set.insert namedElement_Ptype
(Set.insert namedElement_Powner
(Set.insert namedElement_Pattribute
)
)
)
)
)
)
)
)
)
)
)
)
)
, model = Set.insert modelM Set.empty
}
namedElement_String = NamedElement { namedElementName = "String"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_String }
}
type_String = Type { typeSuper = namedElement_String
, typeSubClasses = DDataType { getDataType =
DataType { classSuper = type_String }
}
}
namedElement_UMLModelElement = NamedElement { namedElementName = "UMLModelElement"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_UMLModelElement }
}
type_UMLModelElement = Type { typeSuper = namedElement_UMLModelElement
, typeSubClasses = DClass { getClass = class_UMLModelElement }
}
class_UMLModelElement = Class { classSuperType = type_UMLModelElement
, isAbstract = True
, superClass = Set.empty
}
namedElement_Package = NamedElement { namedElementName = "Package"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_Package }
}
type_Package = Type { typeSuper = namedElement_Package
, typeSubClasses = DClass { getClass = class_Package }
}
class_Package = Class { classSuperType = type_Package
, isAbstract = False
, superClass = Set.insert class_UMLModelElement Set.empty
, ownedAttribute = Set.insert property_elements Set.empty
}
namedElement_Classifier = NamedElement { namedElementName = "Classifier"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_Classifier }
}
type_Classifier = Type { typeSuper = namedElement_Classifier
, typeSubClasses = DClass { getClass = class_Classifier }
}
class_Classifier = Class { classSuperType = type_Classifier
, isAbstract = False
, superClass = Set.insert class_UMLModelElement Set.empty
, ownedAttribute = Set.insert property_namespace Set.empty
}
namedElement_Attribute = NamedElement { namedElementName = "Attribute"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_Attribute }
}
type_Attribute = Type { typeSuper = namedElement_Attribute
, typeSubClasses = DClass { getClass = class_Attribute }
}
class_Attribute = Class { classSuperType = type_Attribute
, isAbstract = False
, superClass = Set.insert class_UMLModelElement Set.empty
}
namedElement_PrimitiveDataType = NamedElement { namedElementName = "PrimitiveDataType"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_PrimitiveDataType }
}
type_PrimitiveDataType = Type { typeSuper = namedElement_PrimitiveDataType
, typeSubClasses = DClass { getClass = class_PrimitiveDataType }
}
class_PrimitiveDataType = Class { classSuperType = type_PrimitiveDataType
, isAbstract = False
, superClass = Set.insert class_Classifier Set.empty
, ownedAttribute = Set.empty
}
namedElement_Class = NamedElement { namedElementName = "Class"
, namedElementOwner = metamodel
, namedElementSubClasses = TType { getType = type_Class }
}
type_Class = Type { typeSuper = namedElement_Class
, typeSubClasses = DClass { getClass = class_Class }
}
class_Class = Class { classSuperType = type_Class
, isAbstract = False
, superClass = Set.insert class_Classifier Set.empty
, ownedAttribute = Set.insert property_attribute Set.empty
}
namedElement_Pkind = NamedElement { namedElementName = "kind"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_kind }
}
typedElement_kind = TypedElement { typedElementSuper = namedElement_Pkind
, typedElementType = type_String
, typedElementSubClasses = property_kind
}
property_kind = Property { propertySuper = typedElement_kind
, multiplicityElement = MultiplicityElement { lower = 1
, upper = 1
, multiplicityElementSubClasses = property_kind
}
, opposite = Nothing
, propertyClass = class_UMLModelElement
}
namedElement_Pname = NamedElement { namedElementName = "name"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_name }
}
typedElement_name = TypedElement { typedElementSuper = namedElement_Pname
, typedElementType = type_String
, typedElementSubClasses = property_name
}
property_name = Property { propertySuper = typedElement_name
, multiplicityElement = MultiplicityElement { lower = 1
, upper = 1
, multiplicityElementSubClasses = property_name
}
, opposite = Nothing
, propertyClass = class_UMLModelElement
}
namedElement_Pnamespace = NamedElement { namedElementName = "namespace"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_namespace }
}
typedElement_namespace = TypedElement { typedElementSuper = namedElement_Pnamespace
, typedElementType = type_Package
, typedElementSubClasses = property_namespace
}
property_namespace = Property { propertySuper = typedElement_namespace
, multiplicityElement = MultiplicityElement { lower = 1
, upper = 1
, multiplicityElementSubClasses = property_namespace
}
, opposite = Just property_elements
, propertyClass = class_Classifier
}
namedElement_Pelements = NamedElement { namedElementName = "elements"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_elements }
}
typedElement_elements = TypedElement { typedElementSuper = namedElement_Pelements
, typedElementType = type_Classifier
, typedElementSubClasses = property_elements
}
property_elements = Property { propertySuper = typedElement_elements
, multiplicityElement = MultiplicityElement { lower = 0
, upper = -1
, multiplicityElementSubClasses = property_elements
}
, opposite = Just property_namespace
, propertyClass = class_Package
}
namedElement_Powner = NamedElement { namedElementName = "owner"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_owner }
}
typedElement_owner = TypedElement { typedElementSuper = namedElement_Powner
, typedElementType = type_Class
, typedElementSubClasses = property_owner
}
property_owner = Property { propertySuper = typedElement_owner
, multiplicityElement = MultiplicityElement { lower = 1
, upper = 1
, multiplicityElementSubClasses = property_owner
}
, opposite = Just property_attribute
, propertyClass = class_Attribute
}
namedElement_Pattribute = NamedElement { namedElementName = "attribute"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_attribute }
}
typedElement_attribute = TypedElement { typedElementSuper = namedElement_Pattribute
, typedElementType = type_Attribute
, typedElementSubClasses = property_attribute
}
property_attribute = Property { propertySuper = typedElement_attribute
, multiplicityElement = MultiplicityElement { lower = 0
, upper = -1
, multiplicityElementSubClasses = property_attribute
}
, opposite = Just property_owner
, propertyClass = class_Class
}
namedElement_Ptype = NamedElement { namedElementName = "type"
, namedElementOwner = metamodel
, namedElementSubClasses = TTypedElement { getTypeElement = typedElement_type }
}
typedElement_type = TypedElement { typedElementSuper = namedElement_Ptype
, typedElementType = type_PrimitiveDataType
, typedElementSubClasses = property_type
}
property_type = Property { propertySuper = typedElement_type
, multiplicityElement = MultiplicityElement { lower = 1
, upper = 1
, multiplicityElementSubClasses = property_type
}
, opposite = Nothing
, propertyClass = class_Attribute
}
modelM = Model { modelName = "ClassModel"
, object = (Set.insert object_p
(Set.insert object_a
(Set.insert object_c
(Set.insert object_pdt
(Set.insert object_Package
(Set.insert object_ID
(Set.insert object_Persistent
(Set.insert object_value
(Set.insert object_String
(Set.insert object_EMPTY
)
)
)
)
)
)
)
)
)
)
, link = (Set.insert link_pc
(Set.insert link_ca
(Set.insert link_apdt
(Set.insert link_pname
(Set.insert link_pkind
(Set.insert link_ppdt
(Set.insert link_aname
(Set.insert link_cname
(Set.insert link_pdtname
(Set.insert link_ckind
(Set.insert link_akind
(Set.insert link_pdtkind
)
)
)
)
)
)
)
)
)
)
)
)
, modelType = metamodel
}
object_p = Object { objectName = "p"
, objectType = type_Package
, objectOwner = modelM
}
object_c = Object { objectName = "c"
, objectType = type_Class
, objectOwner = modelM
}
object_a = Object { objectName = "a"
, objectType = type_Attribute
, objectOwner = modelM
}
object_pdt = Object { objectName = "pdt"
, objectType = type_PrimitiveDataType
, objectOwner = modelM
}
object_Package = Object { objectName = "Package"
, objectType = type_String
, objectOwner = modelM
}
object_ID = Object { objectName = "ID"
, objectType = type_String
, objectOwner = modelM
}
object_Persistent = Object { objectName = "Persistent"
, objectType = type_String
, objectOwner = modelM
}
object_value = Object { objectName = "value"
, objectType = type_String
, objectOwner = modelM
}
object_String = Object { objectName = "String"
, objectType = type_String
, objectOwner = modelM
}
object_EMPTY = Object { objectName = "EMPTY"
, objectType = type_String
, objectOwner = modelM
}
link_pc = Link { linkType = property_elements
, source = object_p
, target = object_c
, linkOwner = modelM
}
link_ppdt = Link { linkType = property_elements
, source = object_p
, target = object_pdt
, linkOwner = modelM
}
link_ca = Link { linkType = property_attribute
, source = object_c
, target = object_a
, linkOwner = modelM
}
link_apdt = Link { linkType = property_type
, source = object_a
, target = object_pdt
, linkOwner = modelM
}
link_pname = Link { linkType = property_name
, source = object_p
, target = object_Package
, linkOwner = modelM
}
link_aname = Link { linkType = property_name
, source = object_a
, target = object_ID
, linkOwner = modelM
}
link_cname = Link { linkType = property_name
, source = object_c
, target = object_value
, linkOwner = modelM
}
link_pdtname = Link { linkType = property_name
, source = object_pdt
, target = object_String
, linkOwner = modelM
}
link_pkind = Link { linkType = property_kind
, source = object_p
, target = object_EMPTY
, linkOwner = modelM
}
link_ckind = Link { linkType = property_kind
, source = object_c
, target = object_Persistent
, linkOwner = modelM
}
link_akind = Link { linkType = property_kind
, source = object_a
, target = object_EMPTY
, linkOwner = modelM
}
link_pdtkind = Link { linkType = property_kind
, source = object_pdt
, target = object_EMPTY
, linkOwner = modelM
}
in
putStrLn (show metamodel)