{-# LANGUAGE DeriveDataTypeable #-}

{- |

Module : $Header$

Description : CSMOF signature and sentences

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.Sign where

import CSMOF.As ()

import qualified Common.Lib.Rel as Rel

import Common.Doc

import Common.DocUtils

import Common.Id

import Data.Data

import qualified Data.Map as Map

import qualified Data.Set as Set

data TypeKind = DataTypeKind | ClassKind

deriving (Show, Eq, Ord, Typeable, Data)

instance Pretty TypeKind where

pretty DataTypeKind = text "datatype"

pretty ClassKind = text "class"

data TypeClass = TypeClass { name :: String, kind :: TypeKind }

deriving (Show, Eq, Ord, Typeable, Data)

instance Pretty TypeClass where

pretty (TypeClass nam _) = text nam

type Role = String

data PropertyT = PropertyT { sourceRole :: Role

, sourceType :: TypeClass

, targetRole :: Role

, targetType :: TypeClass

} deriving (Show, Eq, Ord, Typeable, Data)

instance Pretty PropertyT where

pretty (PropertyT souR souT tarR tarT) = text "property" <> lparen <>

text souR <+> colon <+> pretty souT <+> comma <+> text tarR <+>

colon <+> pretty tarT <> rparen

data LinkT = LinkT { sourceVar :: Role

, targetVar :: Role

, property :: PropertyT

} deriving (Show, Eq, Ord, Typeable, Data)

instance Pretty LinkT where

pretty (LinkT souV tarV pro) = text "link" <> lparen <> text souV <+>

colon <+> text (sourceRole pro) <+> colon <+>

pretty (sourceType pro) <+> comma <+>

text tarV <+> colon <+> text (targetRole pro)

<+> colon <+> pretty (targetType pro) <+>

rparen

data Sign = Sign { types :: Set.Set TypeClass

, typeRel :: Rel.Rel TypeClass

, abstractClasses :: Set.Set TypeClass

, roles :: Set.Set Role

, properties :: Set.Set PropertyT

, instances :: Map.Map String TypeClass

, links :: Set.Set LinkT

} deriving (Show, Eq, Ord, Typeable, Data)

instance GetRange Sign where

getRange _ = nullRange

rangeSpan _ = []

instance Pretty Sign where

pretty (Sign typ tyR abst rol pro ins lin) =

Set.fold (($+$) . toType abst) empty typ

$++$

foldr (($+$) . toSubRel) empty (Rel.toList tyR)

$++$

Set.fold (($+$) . text . ("role " ++)) empty rol

$++$

Set.fold (($+$) . pretty) empty pro

$++$

foldr (($+$) . toInstance) empty (Map.toList ins)

$++$

Set.fold (($+$) . pretty) empty lin

toType :: Set.Set TypeClass -> TypeClass -> Doc

toType setTC (TypeClass nam ki) =

if Set.member (TypeClass nam ki) setTC then

text "abstract" <+> pretty ki <+> text nam

else pretty ki <+> text nam

toSubRel :: (TypeClass, TypeClass) -> Doc

toSubRel (a, b) = pretty a <+> text "<" <+> pretty b

toInstance :: (String, TypeClass) -> Doc

toInstance (a, b) = text "object" <+> text a <+> colon <+> pretty b

emptySign :: Sign

emptySign = Sign { types = Set.empty

, typeRel = Rel.empty

, abstractClasses = Set.empty

, roles = Set.empty

, properties = Set.empty

, instances = Map.empty

, links = Set.empty

}

{- signUnion :: Sign -> Sign -> Result Sign

signUnion s1 s2 = return s1

{ rels = Map.unionWith Set.union (rels s1) (rels s2)

, isas = Rel.union (isas s1) (isas s2) } -}

data MultConstr = MultConstr { getType :: TypeClass

, getRole :: Role

} deriving (Show, Eq, Ord, Typeable, Data)

instance Pretty MultConstr where

pretty (MultConstr tc ro) = pretty tc <> text "." <> text ro

data ConstraintType = EQUAL | LEQ | GEQ deriving (Show, Eq, Ord, Typeable, Data)

instance Pretty ConstraintType where

pretty EQUAL = equals

pretty LEQ = text "<="

pretty GEQ = text ">="

data Sen = Sen { constraint :: MultConstr

, cardinality :: Integer

, constraintType :: ConstraintType

} deriving (Show, Eq, Ord, Typeable, Data)

instance GetRange Sen where

getRange _ = nullRange

rangeSpan _ = []

instance Pretty Sen where

pretty (Sen con car cty) = pretty con <+> pretty cty <+> pretty car