IsomorphicSchema.hs

{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-}
module ProjectM36.IsomorphicSchema where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.MiscUtils
import ProjectM36.Relation
import ProjectM36.NormalizeExpr
import ProjectM36.RelationalExpression
import qualified ProjectM36.AttributeNames as AN
import Control.Monad
import GHC.Generics
import Data.Binary
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.List as L
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
-- isomorphic schemas offer bi-directional functors between two schemas

--TODO: note that renaming a relvar should alter any stored isomorphisms as well
--TODO: rel attrs rename or transform (needs bidirectional atom functions)
-- TODO: IsoRestrict should include requirement that union'd relations should retain the same tuple count (no tuples are lost or ambiguous between the two relations)
--TODO: allow morphs to stack (morph a schema to a new schema)
 -- this could be accomplished by morphing the morphs or by chain linking schemas so that they need not directly reference the underlying concrete schema

-- the isomorphic building blocks should not be arbitrarily combined; for example, combing restrict and union on the same target relvar does not make sense as that would create effects at a distance in the secondary schema

data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |
                  RemoveSubschema SchemaName
                  deriving (Generic, Binary, Show)

  
isomorphs :: Schema -> SchemaIsomorphs
isomorphs (Schema i) = i

-- | Return an error if the schema is not isomorphic to the base database context.
-- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once.
--TODO: add relvar must appear exactly once constraint
validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError
validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff)
                                           | not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes))
                                           | not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes))                
                                           | otherwise = Nothing
  where
    --check that the predicate for IsoUnion and IsoRestrict holds right now
    outDupes = duplicateNames (namesList isomorphOutRelVarNames)
    inDupes = duplicateNames (namesList isomorphInRelVarNames)
    duplicateNames = dupes . L.sort
    namesList isoFunc = concatMap isoFunc (isomorphs potentialSchema)
    expectedRelVars = M.keysSet (relationVariables baseContext)
    schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema)
    rvDiff = S.difference expectedRelVars schemaRelVars

-- useful for transforming a concrete context into a virtual schema and vice versa
invert :: SchemaIsomorph -> SchemaIsomorph
invert (IsoRename rvIn rvOut) = IsoRename rvOut rvIn
invert (IsoRestrict rvIn predi (rvAOut, rvBOut)) = IsoUnion (rvAOut, rvBOut) predi rvIn
invert (IsoUnion (rvAIn, rvBIn) predi rvOut) = IsoRestrict rvOut predi (rvAIn, rvBIn)

isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]
isomorphInRelVarNames (IsoRestrict rv _ _) = [rv]
isomorphInRelVarNames (IsoUnion (rvA, rvB) _ _) = [rvA, rvB]
isomorphInRelVarNames (IsoRename rv _) = [rv]

-- | Relation variables names represented in the virtual schema space. Useful for determining if a relvar name is valid in the schema.
isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
  where
    rvnames morph acc = acc ++ isomorphInRelVarNames morph
    
isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]    
isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB]
isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv]
isomorphOutRelVarNames (IsoRename _ rv) = [rv]

isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
  where
    rvnames morph acc = acc ++ isomorphOutRelVarNames morph

-- | Check that all mentioned relvars are actually present in the current schema.
validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema schema relExprIn = relExprMogrify (\case
                                                                     RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)
                                                                     ex -> Right ex) relExprIn >> pure ()
  where
    validRelVarNames = isomorphsInRelVarNames (isomorphs schema)
  
processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema schema relExprIn = do
  --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)
  let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr
  validateRelationalExprInSchema schema relExprIn                    
  foldM processRelExpr relExprIn (isomorphs schema)
  
validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()  
validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure ()
  
processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr  
processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do
  let relExprMogrifier = processRelationalExprInSchema schema
  --validate that all mentioned relvars are in the valid set
  _ <- validateDatabaseContextExprInSchema schema dbExpr      
  --perform the morph
  foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs

-- | If the database context expression adds or removes a relvar, we need to update the isomorphs to create a passthrough Isomorph.
processDatabaseContextExprSchemaUpdate :: Schema -> DatabaseContextExpr -> Schema
processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr of
  Define rv _ | S.notMember rv validSchemaName -> passthru rv
  Assign rv _ | S.notMember rv validSchemaName -> passthru rv
  Undefine rv | S.member rv validSchemaName -> Schema (filter (elem rv . isomorphInRelVarNames) morphs)
  MultipleExpr exprs -> foldr (flip processDatabaseContextExprSchemaUpdate) schema exprs
  _ -> schema
  where
    validSchemaName = isomorphsInRelVarNames morphs
    passthru rvname = Schema (morphs ++ [IsoRename rvname rvname])
    
processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas    
processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas
  
-- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! 
-- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked.
  {-
-- | Convert inclusion dependencies for display in a specific schema.
applySchemaToInclusionDependencies :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies
applySchemaToInclusionDependencies (Schema morphs) incDeps = 
  let incDepMorph incDep = --check that the mentioned relvars are in fact in the current schema
  M.update incDepMorph incDeps        
  -}

-- | Morph a relational expression in one schema to another isomorphic schema.
relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)
relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \case
  RelationVariable rv () | rv == relIn -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ()))
  orig -> Right orig
relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case
  --only the true predicate portion appears in the virtual schema  
  RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ()))

  RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))
  orig -> Right orig
relExprMorph (IsoRename relIn relOut) = \case
  RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ())
  orig -> Right orig
  
relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr
relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex)
relExprMogrify func (Union exprA exprB) = do
  exA <- func exprA
  exB <- func exprB
  func (Union exA exB)
relExprMogrify func (Join exprA exprB) = do
  exA <- func exprA
  exB <- func exprB
  func (Join exA exB)
relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex)
relExprMogrify func (Difference exprA exprB) = do
  exA <- func exprA
  exB <- func exprB
  func (Difference exA exB)
relExprMogrify func (Group ns n expr) = func expr >>= \ex -> func (Group ns n ex)
relExprMogrify func (Ungroup n expr) = func expr >>= \ex -> func (Ungroup n ex)
relExprMogrify func (Restrict predi expr) = func expr >>= \ex -> func (Restrict predi ex)
relExprMogrify func (Equals exprA exprB) = do
  exA <- func exprA
  exB <- func exprB
  func (Equals exA exB)
relExprMogrify func (NotEquals exprA exprB) = do
  exA <- func exprA
  exB <- func exprB
  func (NotEquals exA exB)
relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)
relExprMogrify func other = func other

{-
spam :: Either RelationalError RelationalExpr
spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())

spam2 :: Either RelationalError RelationalExpr
spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ()) 
-}

databaseContextExprMorph :: SchemaIsomorph  -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) relExprFunc expr = case expr of
  Assign rv relExpr | rv == rvIn -> do
    ex <- relExprFunc relExpr
    let trueExpr n = Assign n (Restrict filt ex)
        falseExpr n = Assign n (Restrict (NotPredicate filt) ex)
    pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
  Insert rv relExpr | rv == rvIn -> do
    ex <- relExprFunc relExpr
    let trueExpr n = Insert n (Restrict filt ex)
        falseExpr n = Insert n (Restrict (NotPredicate filt) ex)
    pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
  Update rv attrMap predi | rv == rvIn -> do
    -- if the update would "shift" a tuple from the true->false relvar or vice versa, that would be a constraint violation in the virtual schema
    let trueExpr n = Update n attrMap (AndPredicate predi filt)
        falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt))
    pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])
  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
  orig -> pure orig                                    
databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of   
  --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr
  --problem: between the delete->insert, constraints could be violated which would not otherwise be violated in the "in" schema. This implies that there should be a combo operator which can insert/update/delete in a single pass based on relexpr queries, or perhaps MultipleExpr should be the infamous "comma" operator from TutorialD?
  -- if any tuples are filtered out of the insert/assign, we need to simulate a constraint violation
  Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,
                                                                                      Insert rvOut (Restrict filt ex)]
  Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),            
                                                                                           Insert rvOut (Restrict (NotPredicate filt) ex)]
  Insert rv relExpr | rv == rvTrue || rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex
  Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)
  Delete rv delPred | rv == rvFalse -> pure $ Delete rvOut (AndPredicate delPred (NotPredicate filt))
  Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)
  Update rv attrMap predi | rv == rvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
  orig -> pure orig
databaseContextExprMorph iso@(IsoRename relIn relOut) relExprFunc expr = case expr of
  Assign rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure (Assign relOut ex)
  Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex
  Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred
  Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi
  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs  
  orig -> pure orig
  
-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.
applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr
applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs

-- the morph must be applied in the opposite direction
--algorithm: create a relexpr for each relvar in the schema, then replace those rel exprs wherever they appear in the inc dep relexprs
-- x = x1 union x2
inclusionDependencyInSchema :: Schema -> InclusionDependency -> Either RelationalError InclusionDependency
inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do
  --collect all relvars which appear in the schema
  let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)
  rvAssoc <- mapM (\rvIn -> do 
                      rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())
                      pure (rvOut, RelationVariable rvIn ())
                  )
             (S.toList schemaRelVars)
  let replacer exprOrig = foldM (\expr (find, replace) -> if expr == find then
                                                            pure replace
                                                          else
                                                            pure expr) exprOrig rvAssoc
  rexprA' <- relExprMogrify replacer rexprA
  rexprB' <- relExprMogrify replacer rexprB
  pure (InclusionDependency rexprA' rexprB')

-- #55 add two virtual constraints for IsoUnion and enforce them before the tuples disappear
-- this is needed to
-- also, it's inverse to IsoRestrict which adds two constraints at the base level
-- for IsoRestrict, consider hiding the two, generated constraints since they can never be thrown in the isomorphic schema
inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies
inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)
  
relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables
relationVariablesInSchema schema@(Schema morphs) = foldM transform M.empty morphs
  where
    transform newRvMap morph = do
      let rvNames = isomorphInRelVarNames morph
      rvAssocs <- mapM (\rv -> do
                           expr' <- processRelationalExprInSchema schema (RelationVariable rv ())
                           let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr')
                           pure (rv, gfExpr)) rvNames
      pure (M.union newRvMap (M.fromList rvAssocs))



{-
proposal
data DatabaseContext = 
Concrete ...|
Virtual Isomorphs
-}
  
applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables                                                                 
applyRelationVariablesSchemaIsomorphs = undefined
  

applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext
applySchemaIsomorphsToDatabaseContext morphs context = do
--  incdeps <- inclusionDependen morphs (inclusionDependencies context)
  relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)
  pure (context { --inclusionDependencies = incdeps,
                  relationVariables = relvars
                  --atomFunctions = atomfuncs,
                  --notifications = notifs,
                  --typeConstructorMapping = tconsmapping
                })
    
{-    
validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph
validate morph underlyingRvNames = if S.size invalidRvNames > 0 then 
                          Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames)))
                         else
                           Right morph
  where
    morphRvNames = S.fromList (isomorphOutRelVarNames morph)
    invalidRvNames = S.difference morphRvNames underlyingRvNames
-}

-- | Create inclusion dependencies mainly for IsoRestrict because the predicate should hold in the base schema.
createIncDepsForIsomorph :: SchemaName -> SchemaIsomorph -> InclusionDependencies
createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = let 
  newIncDep predicate rv = InclusionDependency (Project AN.empty (Restrict predicate (RelationVariable rv ()))) (ExistingRelation relationTrue)
  incDepName b = "schema" <> "_" <> sname <> "_" <> b in
  M.fromList [(incDepName (origRv <> "_true"), newIncDep predi rvTrue),
              (incDepName (origRv <> "_false"), newIncDep (NotPredicate predi) rvFalse)]
createIncDepsForIsomorph _ _ = M.empty

-- in the case of IsoRestrict, the database context should be updated with the restriction so that if the restriction does not hold, then the schema cannot be created
evalSchemaExpr :: SchemaExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)
evalSchemaExpr (AddSubschema sname morphs) context transId graph sschemas =
  if M.member sname sschemas then
    Left (SubschemaNameInUseError sname)
    else
    case validateSchema (Schema morphs) context of
      Just err -> Left (SchemaCreationError err)
      Nothing -> do
        let newSchemas = M.insert sname newSchema sschemas
            newSchema = Schema morphs
            moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs
            incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))
            dbenv = mkDatabaseContextEvalEnv transId graph
        dbstate <- runDatabaseContextEvalMonad context dbenv (evalGraphRefDatabaseContextExpr incDepExprs)
        pure (newSchemas, dbc_context dbstate)
--need to propagate dirty flag here      

evalSchemaExpr (RemoveSubschema sname) context _ _ sschemas = if M.member sname sschemas then
                                           pure (M.delete sname sschemas, context)
                                         else
                                           Left (SubschemaNameNotInUseError sname)