hets/RelationalScheme/Sign.hs

	Sign.hs revision e9458b1a7a19a63aa4c179f9ab20f4d50681c168
{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module      :  ./RelationalScheme/Sign.hs
Description :  signaturefor Relational Schemes
Copyright   :  Dominik Luecke, Uni Bremen 2008
License     :  GPLv2 or higher, see LICENSE.txt or LIZENZ.txt

Maintainer  :  luecke@informatik.uni-bremen.de
Stability   :  provisional
Portability :  portable

Signature for Relational Schemes
-}

module RelationalScheme.Sign
        ( RSIsKey
        , RSDatatype (..)
        , RSRawSymbol
        , RSColumn (..)
        , RSTable (..)
        , RSTables (..)
        , Sign
        , RSMorphism (..)
        , RSTMap (..)
        , emptyRSSign
        , isRSSubsig
        , idMor
        , rsInclusion
        , uniteSig
        , comp_rst_mor
        , RSSymbol (..)
        )
        where

import RelationalScheme.Keywords

import Common.AS_Annotation
import Common.Doc
import Common.DocUtils
import Common.Id
import Common.Result
import Common.Utils

import Data.Data
import qualified Data.Map as Map
import qualified Data.Set as Set

type RSIsKey = Bool

data RSDatatype
  = RSboolean | RSbinary | RSdate | RSdatetime | RSdecimal | RSfloat
  | RSinteger | RSstring | RStext | RStime | RStimestamp | RSdouble
  | RSnonPosInteger | RSnonNegInteger | RSlong | RSPointer
    deriving (Eq, Ord, Typeable, Data)

type RSRawSymbol = Id

data RSSymbol = STable Id |     -- id of a table
                SColumn
                    Id          -- id of the symbol
                    Id          -- id of the table
                    RSDatatype  -- datatype of the symbol
                    RSIsKey     -- is it a key?
                deriving (Eq, Ord, Show, Typeable, Data)

instance GetRange RSSymbol

data RSColumn = RSColumn
                    { c_name :: Id
                    , c_data :: RSDatatype
                    , c_key :: RSIsKey
                    }
                deriving (Eq, Ord, Show, Typeable, Data)

data RSTable = RSTable
                { t_name :: Id
                , columns :: [RSColumn]
                , rsannos :: [Annotation]
                , t_keys :: Set.Set (Id, RSDatatype)
                }
                deriving (Show, Typeable, Data)

data RSTables = RSTables
                    {
                        tables :: Set.Set RSTable
                    }
                deriving (Eq, Ord, Show, Typeable, Data)

instance GetRange RSTables

isRSSubsig :: RSTables -> RSTables -> Bool
isRSSubsig t1 t2 = t1 <= t2

uniteSig :: (Monad m) => RSTables -> RSTables -> m RSTables
uniteSig s1 s2 =
    if s1 `isRSSubsig` s2 || s2 `isRSSubsig` s1 || s1 `isDisjoint` s2
    then return $ RSTables $ tables s1 `Set.union` tables s2
    else fail $ "Tables " ++ showDoc s1 "\nand "
             ++ showDoc s2 "\ncannot be united."

type Sign = RSTables

data RSTMap = RSTMap
                {
                   col_map :: Map.Map Id Id
                }
                deriving (Eq, Ord, Show, Typeable, Data)

data RSMorphism = RSMorphism
                    { domain :: RSTables
                    , codomain :: RSTables
                    , table_map :: Map.Map Id Id
                    , column_map :: Map.Map Id RSTMap
                    }
                    deriving (Eq, Ord, Show, Typeable, Data)

-- I hope that this works right, I do not want to debug this
apply_comp_c_map :: RSTable -> Map.Map Id Id -> RSMorphism -> RSMorphism
                 -> (Id, RSTMap)
apply_comp_c_map rst t_map imap imor =
    let i = t_name rst
        c2 = column_map imor
    in case Map.lookup i $ column_map imap of
      Just iM -> case Map.lookup (Map.findWithDefault i i t_map) c2 of
        Just iM2 ->
          let c_set = Map.fromList . map (\ c -> (c_name c, ())) $ columns rst
              oM = composeMap c_set (col_map iM) (col_map iM2)
          in (i, RSTMap oM)
        Nothing -> (i, iM)
      Nothing -> (i, Map.findWithDefault (RSTMap Map.empty)
                       (Map.findWithDefault i i t_map) c2)

-- composition of Rel morphisms
comp_rst_mor :: RSMorphism -> RSMorphism -> Result RSMorphism
comp_rst_mor mor1 mor2 =
        let d1 = domain mor1
            t1 = Set.toList $ tables d1
            t_set = Map.fromList $ map (\ t -> (t_name t, ())) t1
            t_map = composeMap t_set (table_map mor1) (table_map mor2)
            cm_map = Map.fromList
              $ map (\ x -> apply_comp_c_map x t_map mor1 mor2) t1
        in return RSMorphism
                { domain = d1
                , codomain = codomain mor2
                , table_map = t_map
                , column_map = cm_map
                }

emptyRSSign :: RSTables
emptyRSSign = RSTables
                {
                    tables = Set.empty
                }

-- ^ id-morphism for RS
idMor :: RSTables -> RSMorphism
idMor t = RSMorphism
            { domain = t
            , codomain = t
            , table_map = foldl (\ y x -> Map.insert (t_name x) (t_name x) y)
                          Map.empty $ Set.toList $ tables t
            , column_map =
                    let
                        makeRSTMap i =
                           foldl (\ y x -> Map.insert (c_name x) (c_name x) y)
                                 Map.empty $ columns i
                    in
                        foldl (\ y x -> Map.insert (t_name x)
                                        (RSTMap $ makeRSTMap x) y)
                                Map.empty $ Set.toList $ tables t
            }

rsInclusion :: RSTables -> RSTables -> Result RSMorphism
rsInclusion t1 t2 = return RSMorphism
            { domain = t1
            , codomain = t2
            , table_map = foldl (\ y x -> Map.insert (t_name x) (t_name x) y)
                          Map.empty $ Set.toList $ tables t1
            , column_map =
                    let
                        makeRSTMap i =
                           foldl (\ y x -> Map.insert (c_name x) (c_name x) y)
                                 Map.empty $ columns i
                    in
                        foldl (\ y x -> Map.insert (t_name x)
                                        (RSTMap $ makeRSTMap x) y)
                                Map.empty $ Set.toList $ tables t1
            }

-- pretty printing stuff

instance Pretty RSColumn where
    pretty c = (if c_key c then keyword rsKey else empty) <+>
       pretty (c_name c) <+> colon <+> pretty (c_data c)

instance Pretty RSTable where
    pretty t = pretty (t_name t) <> parens (ppWithCommas $ columns t)
               $+$ printAnnotationList (rsannos t)

instance Pretty RSTables where
    pretty t = keyword rsTables $+$ vcat (map pretty $ Set.toList $ tables t)

instance Pretty RSTMap where
    pretty = pretty . col_map

instance Pretty RSMorphism where
    pretty m = pretty (domain m) $+$ mapsto <+> pretty (codomain m)
                $+$ pretty (table_map m) $+$ pretty (column_map m)

instance Pretty RSSymbol where
    pretty s = case s of
      STable i -> pretty i
      SColumn i _ t k -> pretty $ RSColumn i t k

instance Show RSDatatype where
    show dt = case dt of
        RSboolean -> rsBool
        RSbinary -> rsBin
        RSdate -> rsDate
        RSdatetime -> rsDatetime
        RSdecimal -> rsDecimal
        RSfloat -> rsFloat
        RSinteger -> rsInteger
        RSstring -> rsString
        RStext -> rsText
        RStime -> rsTime
        RStimestamp -> rsTimestamp
        RSdouble -> rsDouble
        RSnonPosInteger -> rsNonPosInteger
        RSnonNegInteger -> rsNonNegInteger
        RSlong -> rsLong
        RSPointer -> rsPointer

instance Pretty RSDatatype where
  pretty = keyword . show

{- we need an explicit instance declaration of Eq and Ord that
correctly deals with tables -}
instance Ord RSTable where
  compare t1 t2 =
    compare (t_name t1, Set.fromList $ columns t1)
            (t_name t2, Set.fromList $ columns t2)

instance Eq RSTable where
  a == b = compare a b == EQ

isDisjoint :: RSTables -> RSTables -> Bool
isDisjoint s1 s2 =
    let
        t1 = Set.map t_name $ tables s1
        t2 = Set.map t_name $ tables s2
    in
        Set.fold (\ x y -> y && (x `Set.notMember` t2)) True t1 &&
        Set.fold (\ x y -> y && (x `Set.notMember` t1)) True t2