content: {-# LANGUAGE DeriveDataTypeable #-}
  {- |
  Module      :  ./RelationalScheme/AS.der.hs
  Description :  abstract syntax for 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
  
  Abstract syntax for Relational Schemes
  -}
  
  module RelationalScheme.AS
          ( RSRelType (..)
          , RSQualId (..)
          , RSRel (..)
          , RSRelationships (..)
          , RSScheme (..)
          , Sentence
          , map_rel
          , getRels
          , getSignature
          ) where
  
  import Data.Data
  import qualified Data.Map as Map
  
  import Common.Id
  import Common.AS_Annotation
  import Common.Doc
  import Common.DocUtils
  import Common.Result
  import qualified Control.Monad.Fail as Fail
  
  import RelationalScheme.Keywords
  import RelationalScheme.Sign
  
  
  -- DrIFT command
  {-! global: GetRange !-}
  
  data RSRelType = RSone_to_one | RSone_to_many | RSmany_to_one | RSmany_to_many
                   deriving (Eq, Ord, Typeable, Data)
  
  -- first Id is TableId, second is columnId
  data RSQualId = RSQualId
                  {
                    table :: Id
                  , column :: Id
                  , q_pos :: Range
                  }
                  deriving (Eq, Ord, Show, Typeable, Data)
  
  data RSRel = RSRel
               {
                 r_lhs :: [RSQualId]
               , r_rhs :: [RSQualId]
               , r_type :: RSRelType
               , r_pos :: Range
               }
               deriving (Eq, Ord, Show, Typeable, Data)
  
  data RSRelationships = RSRelationships [Annoted RSRel] Range
                          deriving (Eq, Ord, Show, Typeable, Data)
  
  data RSScheme = RSScheme RSTables RSRelationships Range
                  deriving (Eq, Ord, Show, Typeable, Data)
  
  type Sentence = RSRel
  
  -- Pretty printing stuff
  
  instance Pretty RSScheme where
    pretty (RSScheme t r _) = pretty t $++$ pretty r
  
  instance Pretty RSRelationships where
    pretty (RSRelationships rs _) = if null rs then empty else
      keyword rsRelationships $+$ vcat (map pretty rs)
  
  instance Pretty RSRel where
    pretty (RSRel i1 i2 tp _) =
      let tbl is = case is of
                 [] -> empty
                 t : _ -> pretty (table t)
               <> brackets (ppWithCommas is)
      in fsep [tbl i1, funArrow, tbl i2, keyword (show tp)]
  
  instance Pretty RSQualId where
    pretty = pretty . column
  
  instance Show RSRelType where
      show r = case r of
          RSone_to_one -> rs1to1
          RSone_to_many -> rs1tom
          RSmany_to_one -> rsmto1
          RSmany_to_many -> rsmtom
  
  
  map_qualId :: RSMorphism -> RSQualId -> Result RSQualId
  map_qualId mor qid =
      let
          (tid, rid, rn) = case qid of
              RSQualId i1 i2 rn1 -> (i1, i2, rn1)
      in maybe (Fail.fail "map_qualId") return $ do
              mtid <- Map.lookup tid $ table_map mor
              rmor <- Map.lookup tid $ column_map mor
              mrid <- Map.lookup rid $ col_map rmor
              return $ RSQualId mtid mrid rn
  
  
  map_rel :: RSMorphism -> RSRel -> Result RSRel
  map_rel mor rel =
      let
          (q1, q2, rt, rn) = case rel of
              RSRel qe1 qe2 rte rne -> (qe1, qe2, rte, rne)
      in
        do
          mq1 <- mapM (map_qualId mor) q1
          mq2 <- mapM (map_qualId mor) q2
          return $ RSRel mq1 mq2 rt rn
  
  {-
  map_arel :: RSMorphism -> (Annoted RSRel) -> Result (Annoted RSRel)
  map_arel mor arel =
      let
          rel = item arel
          (q1, q2, rt, rn) = case rel of
              RSRel qe1 qe2 rte rne -> (qe1, qe2, rte, rne)
      in
        do
          mq1 <- mapM (map_qualId mor) q1
          mq2 <- mapM (map_qualId mor) q2
          return $ arel
                      {
                          item = RSRel mq1 mq2 rt rn
                      }
  
  
  map_relships :: RSMorphism -> RSRelationships -> Result RSRelationships
  map_relships mor rsh =
      let
          (arel, rn) = case rsh of
              RSRelationships arel1 rn1 -> (arel1, rn1)
      in
          do
              orel <- mapM (map_arel mor) arel
              return $ RSRelationships orel rn
  -}
  
  -- ^ oo-style getter function for Relations
  getRels :: RSScheme -> [Annoted RSRel]
  getRels spec = case spec of
              RSScheme _ (RSRelationships rels _) _ -> rels
  
  -- ^ oo-style getter function for signatures
  getSignature :: RSScheme -> RSTables
  getSignature spec = case spec of
              RSScheme tb _ _ -> tb
  