content: {-# 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 (..)
          , RSSymbolKind (..)
          , sym_kind
          )
          where
  
  import RelationalScheme.Keywords
  
  import Common.AS_Annotation
  import Common.Doc
  import Common.DocUtils
  import Common.Id
  import Common.Result
  import Common.Utils
  import qualified Control.Monad.Fail as Fail
  
  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)
  
  data RSSymbolKind = STableK | SColumnK 
    deriving (Eq, Ord, Show, Typeable, Data)
  
  sym_kind :: RSSymbol -> RSSymbolKind
  sym_kind (STable _) = STableK
  sym_kind _ = SColumnK
  
  instance Pretty RSSymbolKind where
   pretty STableK  = text "table"
   pretty SColumnK = text "colum"
  
  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 :: (Fail.MonadFail 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.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
  