content: {-# 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
  