hets/CSMOF/Sign.hs

{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module      :  ./CSMOF/Sign.hs
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