hets/CSMOF/Sign.hs

	Sign.hs revision 3d3889e0cefcdce9b3f43c53aaa201943ac2e895
{- |
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 qualified Data.Map as Map
import qualified Data.Set as Set

data TypeKind = DataTypeKind | ClassKind deriving (Show, Eq, Ord)

instance Pretty TypeKind where
  pretty DataTypeKind = text "datatype"
  pretty ClassKind = text "class"

data TypeClass = TypeClass { name :: String, kind :: TypeKind }
 deriving (Show, Eq, Ord)

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)

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)

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)

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)

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


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

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)

instance GetRange Sen where
  getRange _ = nullRange
  rangeSpan _ = []

instance Pretty Sen where
  pretty (Sen con car cty) = pretty con <+> pretty cty <+> pretty car