{-# LANGUAGE DeriveGeneric, LambdaCase, DerivingVia, FlexibleInstances #-}
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 qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.List as L
import qualified Data.Vector as V
import qualified ProjectM36.Attribute as A
import ProjectM36.AtomType
import Data.Text (Text)
#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 (forall x. Rep SchemaExpr x -> SchemaExpr
forall x. SchemaExpr -> Rep SchemaExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SchemaExpr x -> SchemaExpr
$cfrom :: forall x. SchemaExpr -> Rep SchemaExpr x
Generic, Int -> SchemaExpr -> ShowS
[SchemaExpr] -> ShowS
SchemaExpr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaExpr] -> ShowS
$cshowList :: [SchemaExpr] -> ShowS
show :: SchemaExpr -> String
$cshow :: SchemaExpr -> String
showsPrec :: Int -> SchemaExpr -> ShowS
$cshowsPrec :: Int -> SchemaExpr -> ShowS
Show)

isomorphs :: Schema -> SchemaIsomorphs
isomorphs :: Schema -> SchemaIsomorphs
isomorphs (Schema SchemaIsomorphs
i) = SchemaIsomorphs
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 :: Schema -> DatabaseContext -> Maybe SchemaError
validateSchema Schema
potentialSchema DatabaseContext
baseContext
  | Bool -> Bool
not (forall a. Set a -> Bool
S.null Set IncDepName
rvDiff) = forall a. a -> Maybe a
Just (Set IncDepName -> SchemaError
RelVarReferencesMissing Set IncDepName
rvDiff)
  | Bool
otherwise = case [IncDepName]
outDupes of
      IncDepName
x : [IncDepName]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ IncDepName -> SchemaError
RelVarOutReferencedMoreThanOnce IncDepName
x
      [IncDepName]
_ -> case [IncDepName]
inDupes of
             [] -> forall a. Maybe a
Nothing
             IncDepName
x : [IncDepName]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ IncDepName -> SchemaError
RelVarInReferencedMoreThanOnce IncDepName
x
  where
    --check that the predicate for IsoUnion and IsoRestrict holds right now
    outDupes :: [IncDepName]
outDupes = [IncDepName] -> [IncDepName]
duplicateNames (forall {b}. (SchemaIsomorph -> [b]) -> [b]
namesList SchemaIsomorph -> [IncDepName]
isomorphOutRelVarNames)
    inDupes :: [IncDepName]
inDupes = [IncDepName] -> [IncDepName]
duplicateNames (forall {b}. (SchemaIsomorph -> [b]) -> [b]
namesList SchemaIsomorph -> [IncDepName]
isomorphInRelVarNames)
    duplicateNames :: [IncDepName] -> [IncDepName]
duplicateNames = forall a. Eq a => [a] -> [a]
dupes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
L.sort
    namesList :: (SchemaIsomorph -> [b]) -> [b]
namesList SchemaIsomorph -> [b]
isoFunc = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SchemaIsomorph -> [b]
isoFunc (Schema -> SchemaIsomorphs
isomorphs Schema
potentialSchema)
    expectedRelVars :: Set IncDepName
expectedRelVars = forall k a. Map k a -> Set k
M.keysSet (DatabaseContext -> RelationVariables
relationVariables DatabaseContext
baseContext)
    schemaRelVars :: Set IncDepName
schemaRelVars = SchemaIsomorphs -> Set IncDepName
isomorphsOutRelVarNames (Schema -> SchemaIsomorphs
isomorphs Schema
potentialSchema)
    rvDiff :: Set IncDepName
rvDiff = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set IncDepName
expectedRelVars Set IncDepName
schemaRelVars

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

isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]
isomorphInRelVarNames :: SchemaIsomorph -> [IncDepName]
isomorphInRelVarNames (IsoRestrict IncDepName
rv RestrictionPredicateExpr
_ (IncDepName, IncDepName)
_) = [IncDepName
rv]
isomorphInRelVarNames (IsoUnion (IncDepName
rvA, IncDepName
rvB) RestrictionPredicateExpr
_ IncDepName
_) = [IncDepName
rvA, IncDepName
rvB]
isomorphInRelVarNames (IsoRename IncDepName
rv IncDepName
_) = [IncDepName
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 :: SchemaIsomorphs -> Set IncDepName
isomorphsInRelVarNames SchemaIsomorphs
morphs = forall a. Ord a => [a] -> Set a
S.fromList (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SchemaIsomorph -> [IncDepName] -> [IncDepName]
rvnames [] SchemaIsomorphs
morphs)
  where
    rvnames :: SchemaIsomorph -> [IncDepName] -> [IncDepName]
rvnames SchemaIsomorph
morph [IncDepName]
acc = [IncDepName]
acc forall a. [a] -> [a] -> [a]
++ SchemaIsomorph -> [IncDepName]
isomorphInRelVarNames SchemaIsomorph
morph

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

isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
isomorphsOutRelVarNames :: SchemaIsomorphs -> Set IncDepName
isomorphsOutRelVarNames SchemaIsomorphs
morphs = forall a. Ord a => [a] -> Set a
S.fromList (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SchemaIsomorph -> [IncDepName] -> [IncDepName]
rvnames [] SchemaIsomorphs
morphs)
  where
    rvnames :: SchemaIsomorph -> [IncDepName] -> [IncDepName]
rvnames SchemaIsomorph
morph [IncDepName]
acc = [IncDepName]
acc forall a. [a] -> [a] -> [a]
++ SchemaIsomorph -> [IncDepName]
isomorphOutRelVarNames SchemaIsomorph
morph

-- | Check that all mentioned relvars are actually present in the current schema.
validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema Schema
schema RelationalExpr
relExprIn =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify (\case
                            RelationVariable IncDepName
rv () | forall a. Ord a => a -> Set a -> Bool
S.notMember IncDepName
rv Set IncDepName
validRelVarNames -> forall a b. a -> Either a b
Left (IncDepName -> RelationalError
RelVarNotDefinedError IncDepName
rv)
                            RelationalExpr
ex -> forall a b. b -> Either a b
Right RelationalExpr
ex) RelationalExpr
relExprIn
  where
    validRelVarNames :: Set IncDepName
validRelVarNames = SchemaIsomorphs -> Set IncDepName
isomorphsInRelVarNames (Schema -> SchemaIsomorphs
isomorphs Schema
schema)

processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema (Schema []) RelationalExpr
expr = forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationalExpr
expr
processRelationalExprInSchema Schema
schema RelationalExpr
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 :: RelationalExpr
-> SchemaIsomorph -> Either RelationalError RelationalExpr
processRelExpr RelationalExpr
rexpr SchemaIsomorph
morph = forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify (SchemaIsomorph
-> RelationalExpr -> Either RelationalError RelationalExpr
relExprMorph SchemaIsomorph
morph) RelationalExpr
rexpr
  Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema Schema
schema RelationalExpr
relExprIn
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM RelationalExpr
-> SchemaIsomorph -> Either RelationalError RelationalExpr
processRelExpr RelationalExpr
relExprIn (Schema -> SchemaIsomorphs
isomorphs Schema
schema)

validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()
validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()
validateDatabaseContextExprInSchema Schema
schema DatabaseContextExpr
dbExpr = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\SchemaIsomorph
morph -> SchemaIsomorph
-> (RelationalExpr -> Either RelationalError RelationalExpr)
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
databaseContextExprMorph SchemaIsomorph
morph (\RelationalExpr
e -> Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema Schema
schema RelationalExpr
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationalExpr
e) DatabaseContextExpr
dbExpr) (Schema -> SchemaIsomorphs
isomorphs Schema
schema)

processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
processDatabaseContextExprInSchema :: Schema
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
processDatabaseContextExprInSchema schema :: Schema
schema@(Schema SchemaIsomorphs
morphs) DatabaseContextExpr
dbExpr = do
  let relExprMogrifier :: RelationalExpr -> Either RelationalError RelationalExpr
relExprMogrifier = Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema Schema
schema
  --validate that all mentioned relvars are in the valid set
  ()
_ <- Schema -> DatabaseContextExpr -> Either RelationalError ()
validateDatabaseContextExprInSchema Schema
schema DatabaseContextExpr
dbExpr
  --perform the morph
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\DatabaseContextExpr
ex SchemaIsomorph
morph -> SchemaIsomorph
-> (RelationalExpr -> Either RelationalError RelationalExpr)
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
databaseContextExprMorph SchemaIsomorph
morph RelationalExpr -> Either RelationalError RelationalExpr
relExprMogrifier DatabaseContextExpr
ex) DatabaseContextExpr
dbExpr SchemaIsomorphs
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 -> DatabaseContextExpr -> Schema
processDatabaseContextExprSchemaUpdate schema :: Schema
schema@(Schema SchemaIsomorphs
morphs) DatabaseContextExpr
expr = case DatabaseContextExpr
expr of
  Define IncDepName
rv [AttributeExprBase ()]
_ | forall a. Ord a => a -> Set a -> Bool
S.notMember IncDepName
rv Set IncDepName
validSchemaName -> IncDepName -> Schema
passthru IncDepName
rv
  Assign IncDepName
rv RelationalExpr
_ | forall a. Ord a => a -> Set a -> Bool
S.notMember IncDepName
rv Set IncDepName
validSchemaName -> IncDepName -> Schema
passthru IncDepName
rv
  Undefine IncDepName
rv | forall a. Ord a => a -> Set a -> Bool
S.member IncDepName
rv Set IncDepName
validSchemaName -> SchemaIsomorphs -> Schema
Schema (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem IncDepName
rv forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaIsomorph -> [IncDepName]
isomorphInRelVarNames) SchemaIsomorphs
morphs)
  MultipleExpr [DatabaseContextExpr]
exprs -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip Schema -> DatabaseContextExpr -> Schema
processDatabaseContextExprSchemaUpdate) Schema
schema [DatabaseContextExpr]
exprs
  DatabaseContextExpr
_ -> Schema
schema
  where
    validSchemaName :: Set IncDepName
validSchemaName = SchemaIsomorphs -> Set IncDepName
isomorphsInRelVarNames SchemaIsomorphs
morphs
    passthru :: IncDepName -> Schema
passthru IncDepName
rvname = SchemaIsomorphs -> Schema
Schema (SchemaIsomorphs
morphs forall a. [a] -> [a] -> [a]
++ [IncDepName -> IncDepName -> SchemaIsomorph
IsoRename IncDepName
rvname IncDepName
rvname])

processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas
processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas
processDatabaseContextExprSchemasUpdate Subschemas
subschemas DatabaseContextExpr
expr = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (Schema -> DatabaseContextExpr -> Schema
`processDatabaseContextExprSchemaUpdate` DatabaseContextExpr
expr) Subschemas
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.
-- Returns a function which can be used to morph a 'GraphRefRelationalExpr'. Here, we naively apply the morphs in the current context ignoring past contexts because:
-- * the current schema may not exist in past
-- * this function should only be used for showing DDL, not for expression evaluation.
-- * if a schema were renamed, then the path to past isomorphisms in the transaction graph tree would be lost.
relExprMorph :: SchemaIsomorph -> RelationalExpr -> Either RelationalError RelationalExpr
relExprMorph :: SchemaIsomorph
-> RelationalExpr -> Either RelationalError RelationalExpr
relExprMorph (IsoRestrict IncDepName
relIn RestrictionPredicateExpr
_ (IncDepName
relOutTrue, IncDepName
relOutFalse)) = \case
  RelationVariable IncDepName
rv ()
m | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relIn -> forall a b. b -> Either a b
Right (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
relOutTrue ()
m) (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
relOutFalse ()
m))
  RelationalExpr
orig -> forall a b. b -> Either a b
Right RelationalExpr
orig
relExprMorph (IsoUnion (IncDepName
relInT, IncDepName
relInF) RestrictionPredicateExpr
predi IncDepName
relTarget) = \case
  --only the true predicate portion appears in the virtual schema
  RelationVariable IncDepName
rv ()
m | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relInT -> forall a b. b -> Either a b
Right (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExpr
predi (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
relTarget ()
m))

  RelationVariable IncDepName
rv ()
m | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relInF -> forall a b. b -> Either a b
Right (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
predi) (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
relTarget ()
m))
  RelationalExpr
orig -> forall a b. b -> Either a b
Right RelationalExpr
orig
relExprMorph (IsoRename IncDepName
relIn IncDepName
relOut) = \case
  RelationVariable IncDepName
rv ()
m | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relIn -> forall a b. b -> Either a b
Right (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
relOut ()
m)
  RelationalExpr
orig -> forall a b. b -> Either a b
Right RelationalExpr
orig

relExprMogrify :: (RelationalExprBase a -> Either RelationalError (RelationalExprBase a)) -> RelationalExprBase a -> Either RelationalError (RelationalExprBase a)
relExprMogrify :: forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Project AttributeNamesBase a
attrs RelationalExprBase a
expr) = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExprBase a
ex -> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project AttributeNamesBase a
attrs RelationalExprBase a
ex)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Union RelationalExprBase a
exprA RelationalExprBase a
exprB) = do
  RelationalExprBase a
exA <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprA
  RelationalExprBase a
exB <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprB
  RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Union RelationalExprBase a
exA RelationalExprBase a
exB)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Join RelationalExprBase a
exprA RelationalExprBase a
exprB) = do
  RelationalExprBase a
exA <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprA
  RelationalExprBase a
exB <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprB
  RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Join RelationalExprBase a
exA RelationalExprBase a
exB)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Rename Set (IncDepName, IncDepName)
attrs RelationalExprBase a
expr) = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExprBase a
ex -> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
Set (IncDepName, IncDepName)
-> RelationalExprBase a -> RelationalExprBase a
Rename Set (IncDepName, IncDepName)
attrs RelationalExprBase a
ex)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Difference RelationalExprBase a
exprA RelationalExprBase a
exprB) = do
  RelationalExprBase a
exA <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprA
  RelationalExprBase a
exB <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprB
  RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Difference RelationalExprBase a
exA RelationalExprBase a
exB)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Group AttributeNamesBase a
ns IncDepName
n RelationalExprBase a
expr) = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExprBase a
ex -> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
AttributeNamesBase a
-> IncDepName -> RelationalExprBase a -> RelationalExprBase a
Group AttributeNamesBase a
ns IncDepName
n RelationalExprBase a
ex)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Ungroup IncDepName
n RelationalExprBase a
expr) = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExprBase a
ex -> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
IncDepName -> RelationalExprBase a -> RelationalExprBase a
Ungroup IncDepName
n RelationalExprBase a
ex)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Restrict RestrictionPredicateExprBase a
predi RelationalExprBase a
expr) = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExprBase a
ex -> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExprBase a
predi RelationalExprBase a
ex)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Equals RelationalExprBase a
exprA RelationalExprBase a
exprB) = do
  RelationalExprBase a
exA <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprA
  RelationalExprBase a
exB <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprB
  RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Equals RelationalExprBase a
exA RelationalExprBase a
exB)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (NotEquals RelationalExprBase a
exprA RelationalExprBase a
exprB) = do
  RelationalExprBase a
exA <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprA
  RelationalExprBase a
exB <- RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
exprB
  RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
RelationalExprBase a
-> RelationalExprBase a -> RelationalExprBase a
NotEquals RelationalExprBase a
exA RelationalExprBase a
exB)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (Extend ExtendTupleExprBase a
ext RelationalExprBase a
expr) = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExprBase a
ex -> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func (forall a.
ExtendTupleExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Extend ExtendTupleExprBase a
ext RelationalExprBase a
ex)
relExprMogrify RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
other = RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
func RelationalExprBase a
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 :: SchemaIsomorph
-> (RelationalExpr -> Either RelationalError RelationalExpr)
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
databaseContextExprMorph iso :: SchemaIsomorph
iso@(IsoRestrict IncDepName
rvIn RestrictionPredicateExpr
filt (IncDepName
rvTrue, IncDepName
rvFalse)) RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc DatabaseContextExpr
expr = case DatabaseContextExpr
expr of
  Assign IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvIn -> do
    RelationalExpr
ex <- RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr
    let trueExpr :: IncDepName -> DatabaseContextExpr
trueExpr IncDepName
n = forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Assign IncDepName
n (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExpr
filt RelationalExpr
ex)
        falseExpr :: IncDepName -> DatabaseContextExpr
falseExpr IncDepName
n = forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Assign IncDepName
n (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt) RelationalExpr
ex)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr [IncDepName -> DatabaseContextExpr
trueExpr IncDepName
rvTrue, IncDepName -> DatabaseContextExpr
falseExpr IncDepName
rvFalse]
  Insert IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvIn -> do
    RelationalExpr
ex <- RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr
    let trueExpr :: IncDepName -> DatabaseContextExpr
trueExpr IncDepName
n = forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert IncDepName
n (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExpr
filt RelationalExpr
ex)
        falseExpr :: IncDepName -> DatabaseContextExpr
falseExpr IncDepName
n = forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert IncDepName
n (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt) RelationalExpr
ex)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr [IncDepName -> DatabaseContextExpr
trueExpr IncDepName
rvTrue, IncDepName -> DatabaseContextExpr
falseExpr IncDepName
rvFalse]
  Update IncDepName
rv AttributeNameAtomExprMap
attrMap RestrictionPredicateExpr
predi | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
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 :: IncDepName -> DatabaseContextExpr
trueExpr IncDepName
n = forall a.
IncDepName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExprBase a
-> DatabaseContextExprBase a
Update IncDepName
n AttributeNameAtomExprMap
attrMap (forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate RestrictionPredicateExpr
predi RestrictionPredicateExpr
filt)
        falseExpr :: IncDepName -> DatabaseContextExpr
falseExpr IncDepName
n = forall a.
IncDepName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExprBase a
-> DatabaseContextExprBase a
Update IncDepName
n AttributeNameAtomExprMap
attrMap (forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate RestrictionPredicateExpr
predi (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr [IncDepName -> DatabaseContextExpr
trueExpr IncDepName
rvTrue, IncDepName -> DatabaseContextExpr
falseExpr IncDepName
rvFalse])
  MultipleExpr [DatabaseContextExpr]
exprs -> forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SchemaIsomorph
-> (RelationalExpr -> Either RelationalError RelationalExpr)
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
databaseContextExprMorph SchemaIsomorph
iso RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc) [DatabaseContextExpr]
exprs
  DatabaseContextExpr
orig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContextExpr
orig
databaseContextExprMorph iso :: SchemaIsomorph
iso@(IsoUnion (IncDepName
rvTrue, IncDepName
rvFalse) RestrictionPredicateExpr
filt IncDepName
rvOut) RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc DatabaseContextExpr
expr = case DatabaseContextExpr
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 IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvTrue -> RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExpr
ex -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr [forall a.
IncDepName
-> RestrictionPredicateExprBase a -> DatabaseContextExprBase a
Delete IncDepName
rvOut RestrictionPredicateExpr
filt,
                                                                                      forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert IncDepName
rvOut (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExpr
filt RelationalExpr
ex)]
  Assign IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvFalse -> RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExpr
ex -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr [forall a.
IncDepName
-> RestrictionPredicateExprBase a -> DatabaseContextExprBase a
Delete IncDepName
rvOut (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt),
                                                                                           forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert IncDepName
rvOut (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt) RelationalExpr
ex)]
  Insert IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvTrue Bool -> Bool -> Bool
|| IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvFalse -> RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExpr
ex -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert IncDepName
rvOut RelationalExpr
ex
  Delete IncDepName
rv RestrictionPredicateExpr
delPred | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvTrue -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName
-> RestrictionPredicateExprBase a -> DatabaseContextExprBase a
Delete IncDepName
rvOut (forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate RestrictionPredicateExpr
delPred RestrictionPredicateExpr
filt)
  Delete IncDepName
rv RestrictionPredicateExpr
delPred | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvFalse -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName
-> RestrictionPredicateExprBase a -> DatabaseContextExprBase a
Delete IncDepName
rvOut (forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate RestrictionPredicateExpr
delPred (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt))
  Update IncDepName
rv AttributeNameAtomExprMap
attrMap RestrictionPredicateExpr
predi | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvTrue -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExprBase a
-> DatabaseContextExprBase a
Update IncDepName
rvOut AttributeNameAtomExprMap
attrMap (forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate RestrictionPredicateExpr
predi RestrictionPredicateExpr
filt)
  Update IncDepName
rv AttributeNameAtomExprMap
attrMap RestrictionPredicateExpr
predi | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
rvFalse -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExprBase a
-> DatabaseContextExprBase a
Update IncDepName
rvOut AttributeNameAtomExprMap
attrMap (forall a.
RestrictionPredicateExprBase a
-> RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
AndPredicate (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
filt) RestrictionPredicateExpr
predi)
  MultipleExpr [DatabaseContextExpr]
exprs -> forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SchemaIsomorph
-> (RelationalExpr -> Either RelationalError RelationalExpr)
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
databaseContextExprMorph SchemaIsomorph
iso RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc) [DatabaseContextExpr]
exprs
  DatabaseContextExpr
orig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContextExpr
orig
databaseContextExprMorph iso :: SchemaIsomorph
iso@(IsoRename IncDepName
relIn IncDepName
relOut) RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc DatabaseContextExpr
expr = case DatabaseContextExpr
expr of
  Assign IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relIn -> RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExpr
ex -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Assign IncDepName
relOut RelationalExpr
ex)
  Insert IncDepName
rv RelationalExpr
relExpr | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relIn -> RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc RelationalExpr
relExpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \RelationalExpr
ex -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName -> RelationalExprBase a -> DatabaseContextExprBase a
Insert IncDepName
relOut RelationalExpr
ex
  Delete IncDepName
rv RestrictionPredicateExpr
delPred | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relIn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName
-> RestrictionPredicateExprBase a -> DatabaseContextExprBase a
Delete IncDepName
relOut RestrictionPredicateExpr
delPred
  Update IncDepName
rv AttributeNameAtomExprMap
attrMap RestrictionPredicateExpr
predi | IncDepName
rv forall a. Eq a => a -> a -> Bool
== IncDepName
relIn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
IncDepName
-> AttributeNameAtomExprMap
-> RestrictionPredicateExprBase a
-> DatabaseContextExprBase a
Update IncDepName
relOut AttributeNameAtomExprMap
attrMap RestrictionPredicateExpr
predi
  MultipleExpr [DatabaseContextExpr]
exprs -> forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SchemaIsomorph
-> (RelationalExpr -> Either RelationalError RelationalExpr)
-> DatabaseContextExpr
-> Either RelationalError DatabaseContextExpr
databaseContextExprMorph SchemaIsomorph
iso RelationalExpr -> Either RelationalError RelationalExpr
relExprFunc) [DatabaseContextExpr]
exprs
  DatabaseContextExpr
orig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContextExpr
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 :: SchemaIsomorphs
-> RelationalExpr -> Either RelationalError RelationalExpr
applyRelationalExprSchemaIsomorphs SchemaIsomorphs
morphs RelationalExpr
expr = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\RelationalExpr
expr' SchemaIsomorph
morph -> forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify (SchemaIsomorph
-> RelationalExpr -> Either RelationalError RelationalExpr
relExprMorph SchemaIsomorph
morph) RelationalExpr
expr') RelationalExpr
expr SchemaIsomorphs
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
-> Either RelationalError InclusionDependency
inclusionDependencyInSchema Schema
schema (InclusionDependency RelationalExpr
rexprA RelationalExpr
rexprB) = do
  --collect all relvars which appear in the schema
  let schemaRelVars :: Set IncDepName
schemaRelVars = SchemaIsomorphs -> Set IncDepName
isomorphsInRelVarNames (Schema -> SchemaIsomorphs
isomorphs Schema
schema)
  [(RelationalExpr, RelationalExpr)]
rvAssoc <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\IncDepName
rvIn -> do
                      RelationalExpr
rvOut <- Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema Schema
schema (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
rvIn ())
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalExpr
rvOut, forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
rvIn ())
                  )
             (forall a. Set a -> [a]
S.toList Set IncDepName
schemaRelVars)
  let replacer :: RelationalExpr -> m RelationalExpr
replacer RelationalExpr
exprOrig = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\RelationalExpr
expr (RelationalExpr
find, RelationalExpr
replace) -> if RelationalExpr
expr forall a. Eq a => a -> a -> Bool
== RelationalExpr
find then
                                                            forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationalExpr
replace
                                                          else
                                                            forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationalExpr
expr) RelationalExpr
exprOrig [(RelationalExpr, RelationalExpr)]
rvAssoc
  RelationalExpr
rexprA' <- forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify forall {m :: * -> *}. Monad m => RelationalExpr -> m RelationalExpr
replacer RelationalExpr
rexprA
  RelationalExpr
rexprB' <- forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify forall {m :: * -> *}. Monad m => RelationalExpr -> m RelationalExpr
replacer RelationalExpr
rexprB
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalExpr -> RelationalExpr -> InclusionDependency
InclusionDependency RelationalExpr
rexprA' RelationalExpr
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
-> InclusionDependencies
-> Either RelationalError InclusionDependencies
inclusionDependenciesInSchema Schema
schema InclusionDependencies
incDeps = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(IncDepName
depName, InclusionDependency
dep) -> Schema
-> InclusionDependency
-> Either RelationalError InclusionDependency
inclusionDependencyInSchema Schema
schema InclusionDependency
dep forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \InclusionDependency
newDep -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (IncDepName
depName, InclusionDependency
newDep)) (forall k a. Map k a -> [(k, a)]
M.toList InclusionDependencies
incDeps)

relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables
relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables
relationVariablesInSchema schema :: Schema
schema@(Schema SchemaIsomorphs
morphs) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM RelationVariables
-> SchemaIsomorph -> Either RelationalError RelationVariables
transform forall k a. Map k a
M.empty SchemaIsomorphs
morphs
  where
    transform :: RelationVariables
-> SchemaIsomorph -> Either RelationalError RelationVariables
transform RelationVariables
newRvMap SchemaIsomorph
morph = do
      let rvNames :: [IncDepName]
rvNames = SchemaIsomorph -> [IncDepName]
isomorphInRelVarNames SchemaIsomorph
morph
      [(IncDepName, GraphRefRelationalExpr)]
rvAssocs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\IncDepName
rv -> do
                           RelationalExpr
expr' <- Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema Schema
schema (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
rv ())
                           let gfExpr :: GraphRefRelationalExpr
gfExpr = forall a. GraphRefTransactionMarker -> ProcessExprM a -> a
runProcessExprM GraphRefTransactionMarker
UncommittedContextMarker (RelationalExpr -> ProcessExprM GraphRefRelationalExpr
processRelationalExpr RelationalExpr
expr')
                           forall (f :: * -> *) a. Applicative f => a -> f a
pure (IncDepName
rv, GraphRefRelationalExpr
gfExpr)) [IncDepName]
rvNames
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union RelationVariables
newRvMap (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(IncDepName, GraphRefRelationalExpr)]
rvAssocs))


-- | Show metadata about the relation variables in the isomorphic schema.
relationVariablesAsRelationInSchema :: DatabaseContext -> Schema -> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelationInSchema :: DatabaseContext
-> Schema -> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelationInSchema DatabaseContext
ctx (Schema []) TransactionGraph
graph = DatabaseContext
-> TransactionGraph -> Either RelationalError Relation
relationVariablesAsRelation DatabaseContext
ctx TransactionGraph
graph -- no schema morphism
relationVariablesAsRelationInSchema DatabaseContext
concreteDbContext Schema
schema TransactionGraph
graph = do
  RelationVariables
rvDefsInConcreteSchema <- Schema -> Either RelationalError RelationVariables
relationVariablesInSchema Schema
schema
  let gfEnv :: GraphRefRelationalExprEnv
gfEnv = Maybe DatabaseContext
-> TransactionGraph -> GraphRefRelationalExprEnv
freshGraphRefRelationalExprEnv (forall a. a -> Maybe a
Just DatabaseContext
concreteDbContext) TransactionGraph
graph
  [(IncDepName, Relation)]
typAssocs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
M.toList RelationVariables
rvDefsInConcreteSchema) forall a b. (a -> b) -> a -> b
$ \(IncDepName
rv, GraphRefRelationalExpr
gfExpr) -> do
    Relation
typ <- forall a.
GraphRefRelationalExprEnv
-> GraphRefRelationalExprM a -> Either RelationalError a
runGraphRefRelationalExprM GraphRefRelationalExprEnv
gfEnv (GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
typeForGraphRefRelationalExpr GraphRefRelationalExpr
gfExpr)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (IncDepName
rv, Relation
typ)
  let tups :: [[Atom]]
tups = forall a b. (a -> b) -> [a] -> [b]
map (IncDepName, Relation) -> [Atom]
relVarToAtomList [(IncDepName, Relation)]
typAssocs
      subrelAttrs :: Attributes
subrelAttrs = [Attribute] -> Attributes
A.attributesFromList [IncDepName -> AtomType -> Attribute
Attribute IncDepName
"attribute" AtomType
TextAtomType, IncDepName -> AtomType -> Attribute
Attribute IncDepName
"type" AtomType
TextAtomType]
      attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [IncDepName -> AtomType -> Attribute
Attribute IncDepName
"name" AtomType
TextAtomType,
                                  IncDepName -> AtomType -> Attribute
Attribute IncDepName
"attributes" (Attributes -> AtomType
RelationAtomType Attributes
subrelAttrs)]
      relVarToAtomList :: (IncDepName, Relation) -> [Atom]
relVarToAtomList (IncDepName
rvName, Relation
rel) = [IncDepName -> Atom
TextAtom IncDepName
rvName, Vector Attribute -> Atom
attributesToRel (Attributes -> Vector Attribute
attributesVec (Relation -> Attributes
attributes Relation
rel))]
      attrAtoms :: Attribute -> [Atom]
attrAtoms Attribute
a = [IncDepName -> Atom
TextAtom (Attribute -> IncDepName
A.attributeName Attribute
a), IncDepName -> Atom
TextAtom (AtomType -> IncDepName
prettyAtomType (Attribute -> AtomType
A.atomType Attribute
a))]
      attributesToRel :: Vector Attribute -> Atom
attributesToRel Vector Attribute
attrl = case Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
subrelAttrs (forall a b. (a -> b) -> [a] -> [b]
map Attribute -> [Atom]
attrAtoms (forall a. Vector a -> [a]
V.toList Vector Attribute
attrl)) of
        Left RelationalError
err -> forall a. HasCallStack => String -> a
error (String
"relationVariablesAsRelation pooped " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show RelationalError
err)
        Right Relation
rel -> Relation -> Atom
RelationAtom Relation
rel
  Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
tups

{-
proposal
data DatabaseContext =
Concrete ...|
Virtual Isomorphs
-}
{-
applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables
applyRelationVariablesSchemaIsomorphs {-morphs rvs -}= undefined
-}
{-  M.fromList <$> mapM (\(rvname, rvexpr) -> do
                          morphed <- applyRelationalExprSchemaIsomorphs morphs rvexpr
                          pure (rvname, morphed)
                      ) (M.toList rvs)
  -}
{-
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 :: IncDepName -> SchemaIsomorph -> InclusionDependencies
createIncDepsForIsomorph IncDepName
sname (IsoRestrict IncDepName
origRv RestrictionPredicateExpr
predi (IncDepName
rvTrue, IncDepName
rvFalse)) = let
  newIncDep :: RestrictionPredicateExpr -> IncDepName -> InclusionDependency
newIncDep RestrictionPredicateExpr
predicate IncDepName
rv = RelationalExpr -> RelationalExpr -> InclusionDependency
InclusionDependency (forall a.
AttributeNamesBase a
-> RelationalExprBase a -> RelationalExprBase a
Project forall a. AttributeNamesBase a
AN.empty (forall a.
RestrictionPredicateExprBase a
-> RelationalExprBase a -> RelationalExprBase a
Restrict RestrictionPredicateExpr
predicate (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
rv ()))) (forall a. Relation -> RelationalExprBase a
ExistingRelation Relation
relationTrue)
  incDepName :: IncDepName -> IncDepName
incDepName IncDepName
b = IncDepName
"schema" forall a. Semigroup a => a -> a -> a
<> IncDepName
"_" forall a. Semigroup a => a -> a -> a
<> IncDepName
sname forall a. Semigroup a => a -> a -> a
<> IncDepName
"_" forall a. Semigroup a => a -> a -> a
<> IncDepName
b in
  forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(IncDepName -> IncDepName
incDepName (IncDepName
origRv forall a. Semigroup a => a -> a -> a
<> IncDepName
"_true"), RestrictionPredicateExpr -> IncDepName -> InclusionDependency
newIncDep RestrictionPredicateExpr
predi IncDepName
rvTrue),
              (IncDepName -> IncDepName
incDepName (IncDepName
origRv forall a. Semigroup a => a -> a -> a
<> IncDepName
"_false"), RestrictionPredicateExpr -> IncDepName -> InclusionDependency
newIncDep (forall a.
RestrictionPredicateExprBase a -> RestrictionPredicateExprBase a
NotPredicate RestrictionPredicateExpr
predi) IncDepName
rvFalse)]
createIncDepsForIsomorph IncDepName
_ SchemaIsomorph
_ = forall k a. Map k a
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 :: SchemaExpr
-> DatabaseContext
-> TransactionId
-> TransactionGraph
-> Subschemas
-> Either RelationalError (Subschemas, DatabaseContext)
evalSchemaExpr (AddSubschema IncDepName
sname SchemaIsomorphs
morphs) DatabaseContext
context TransactionId
transId TransactionGraph
graph Subschemas
sschemas =
  if forall k a. Ord k => k -> Map k a -> Bool
M.member IncDepName
sname Subschemas
sschemas then
    forall a b. a -> Either a b
Left (IncDepName -> RelationalError
SubschemaNameInUseError IncDepName
sname)
    else
    case Schema -> DatabaseContext -> Maybe SchemaError
validateSchema (SchemaIsomorphs -> Schema
Schema SchemaIsomorphs
morphs) DatabaseContext
context of
      Just SchemaError
err -> forall a b. a -> Either a b
Left (SchemaError -> RelationalError
SchemaCreationError SchemaError
err)
      Maybe SchemaError
Nothing -> do
        let newSchemas :: Subschemas
newSchemas = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert IncDepName
sname Schema
newSchema Subschemas
sschemas
            newSchema :: Schema
newSchema = SchemaIsomorphs -> Schema
Schema SchemaIsomorphs
morphs
            moreIncDeps :: InclusionDependencies
moreIncDeps = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\SchemaIsomorph
morph InclusionDependencies
acc -> forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union InclusionDependencies
acc (IncDepName -> SchemaIsomorph -> InclusionDependencies
createIncDepsForIsomorph IncDepName
sname SchemaIsomorph
morph)) forall k a. Map k a
M.empty SchemaIsomorphs
morphs
            incDepExprs :: DatabaseContextExprBase a
incDepExprs = forall a. [DatabaseContextExprBase a] -> DatabaseContextExprBase a
MultipleExpr (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a.
IncDepName -> InclusionDependency -> DatabaseContextExprBase a
AddInclusionDependency) (forall k a. Map k a -> [(k, a)]
M.toList InclusionDependencies
moreIncDeps))
            dbenv :: DatabaseContextEvalEnv
dbenv = TransactionId -> TransactionGraph -> DatabaseContextEvalEnv
mkDatabaseContextEvalEnv TransactionId
transId TransactionGraph
graph
        DatabaseContextEvalState
dbstate <- DatabaseContext
-> DatabaseContextEvalEnv
-> DatabaseContextEvalMonad ()
-> Either RelationalError DatabaseContextEvalState
runDatabaseContextEvalMonad DatabaseContext
context DatabaseContextEvalEnv
dbenv (GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()
evalGraphRefDatabaseContextExpr forall {a}. DatabaseContextExprBase a
incDepExprs)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subschemas
newSchemas, DatabaseContextEvalState -> DatabaseContext
dbc_context DatabaseContextEvalState
dbstate)
--need to propagate dirty flag here

evalSchemaExpr (RemoveSubschema IncDepName
sname) DatabaseContext
context TransactionId
_ TransactionGraph
_ Subschemas
sschemas = if forall k a. Ord k => k -> Map k a -> Bool
M.member IncDepName
sname Subschemas
sschemas then
                                           forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => k -> Map k a -> Map k a
M.delete IncDepName
sname Subschemas
sschemas, DatabaseContext
context)
                                         else
                                           forall a b. a -> Either a b
Left (IncDepName -> RelationalError
SubschemaNameNotInUseError IncDepName
sname)


-- | Apply SchemaIsomorphs to database context data.
class Morph a where
  morphToSchema :: Schema -> TransactionGraph -> a -> Either RelationalError a

instance Morph RelationalExpr where
  morphToSchema :: Schema
-> TransactionGraph
-> RelationalExpr
-> Either RelationalError RelationalExpr
morphToSchema Schema
schema TransactionGraph
_ RelationalExpr
relExprIn = do
      let processRelExpr :: RelationalExpr
-> SchemaIsomorph -> Either RelationalError RelationalExpr
processRelExpr RelationalExpr
rexpr SchemaIsomorph
morph = forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify (SchemaIsomorph
-> RelationalExpr -> Either RelationalError RelationalExpr
relExprMorph SchemaIsomorph
morph) RelationalExpr
rexpr
      Schema -> RelationalExpr -> Either RelationalError ()
validateRelationalExprInSchema Schema
schema RelationalExpr
relExprIn
      forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM RelationalExpr
-> SchemaIsomorph -> Either RelationalError RelationalExpr
processRelExpr RelationalExpr
relExprIn (Schema -> SchemaIsomorphs
isomorphs Schema
schema)

-- | The names of inclusion dependencies might leak context about a different schema, but that's arbitrary and cannot be altered without having the user provide a renaming function or a new set of incDep names- seems extraneous.
instance Morph InclusionDependency where
  morphToSchema :: Schema
-> TransactionGraph
-> InclusionDependency
-> Either RelationalError InclusionDependency
morphToSchema Schema
schema TransactionGraph
_ (InclusionDependency RelationalExpr
rexprA RelationalExpr
rexprB) = do
    let schemaRelVars :: Set IncDepName
schemaRelVars = SchemaIsomorphs -> Set IncDepName
isomorphsInRelVarNames (Schema -> SchemaIsomorphs
isomorphs Schema
schema)
    [(RelationalExpr, RelationalExpr)]
rvAssoc <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\IncDepName
rvIn -> do
                      RelationalExpr
rvOut <- Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema Schema
schema (forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
rvIn ())
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalExpr
rvOut, forall a. IncDepName -> a -> RelationalExprBase a
RelationVariable IncDepName
rvIn ())
                  )
             (forall a. Set a -> [a]
S.toList Set IncDepName
schemaRelVars)
    let replacer :: RelationalExpr -> m RelationalExpr
replacer RelationalExpr
exprOrig = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\RelationalExpr
expr (RelationalExpr
find, RelationalExpr
replace) -> if RelationalExpr
expr forall a. Eq a => a -> a -> Bool
== RelationalExpr
find then
                                                              forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationalExpr
replace
                                                            else
                                                              forall (f :: * -> *) a. Applicative f => a -> f a
pure RelationalExpr
expr) RelationalExpr
exprOrig [(RelationalExpr, RelationalExpr)]
rvAssoc
    RelationalExpr
rexprA' <- forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify forall {m :: * -> *}. Monad m => RelationalExpr -> m RelationalExpr
replacer RelationalExpr
rexprA
    RelationalExpr
rexprB' <- forall a.
(RelationalExprBase a
 -> Either RelationalError (RelationalExprBase a))
-> RelationalExprBase a
-> Either RelationalError (RelationalExprBase a)
relExprMogrify forall {m :: * -> *}. Monad m => RelationalExpr -> m RelationalExpr
replacer RelationalExpr
rexprB
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelationalExpr -> RelationalExpr -> InclusionDependency
InclusionDependency RelationalExpr
rexprA' RelationalExpr
rexprB')

instance Morph InclusionDependencies where
  morphToSchema :: Schema
-> TransactionGraph
-> InclusionDependencies
-> Either RelationalError InclusionDependencies
morphToSchema Schema
schema TransactionGraph
tg InclusionDependencies
incDeps = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(IncDepName
n,InclusionDependency
incdep) -> (,) IncDepName
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
Morph a =>
Schema -> TransactionGraph -> a -> Either RelationalError a
morphToSchema Schema
schema TransactionGraph
tg InclusionDependency
incdep) (forall k a. Map k a -> [(k, a)]
M.toList InclusionDependencies
incDeps)

{-
-- cannot be implemented because relvars map to transaction-graph-traversing expressions and we do not track schema changes over time
instance Morph RelationVariables where
  morphToSchema schema tg relVars = do
    let folder acc (IsoRename rvBase rvSchema) =
          case M.lookup rvBase relVars of
            Nothing -> Left (RelVarNotDefinedError rvBase)
            Just gfExpr -> do
              gfExprSchema <- morphToSchema schema tg gfExpr
              pure (acc <> [(rvSchema, gfExprSchema)])
    M.fromList <$> foldM folder mempty (isomorphs schema)
-}
{-
instance Morph GraphRefRelationalExpr where
-- cannot be supported because we don't track how the schema changes over the lifetime of a transaction graph
-}

notificationsAsRelationInSchema :: Notifications -> Schema -> Either RelationalError Relation
notificationsAsRelationInSchema :: Notifications -> Schema -> Either RelationalError Relation
notificationsAsRelationInSchema Notifications
notifs Schema
schema  = do
  let attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [IncDepName -> AtomType -> Attribute
Attribute IncDepName
"name" AtomType
TextAtomType,
                                    IncDepName -> AtomType -> Attribute
Attribute IncDepName
"changeExpr" AtomType
RelationalExprAtomType,
                                    IncDepName -> AtomType -> Attribute
Attribute IncDepName
"reportOldExpr" AtomType
RelationalExprAtomType,
                                    IncDepName -> AtomType -> Attribute
Attribute IncDepName
"reportNewExpr" AtomType
RelationalExprAtomType]
      relExprT :: RelationalExpr -> Either RelationalError RelationalExpr
relExprT = Schema -> RelationalExpr -> Either RelationalError RelationalExpr
processRelationalExprInSchema Schema
schema
      transform :: (a, RelationalExpr, RelationalExpr, RelationalExpr)
-> Either
     RelationalError (a, RelationalExpr, RelationalExpr, RelationalExpr)
transform (a
name, RelationalExpr
e1, RelationalExpr
e2, RelationalExpr
e3) = do
        RelationalExpr
e1' <- RelationalExpr -> Either RelationalError RelationalExpr
relExprT RelationalExpr
e1
        RelationalExpr
e2' <- RelationalExpr -> Either RelationalError RelationalExpr
relExprT RelationalExpr
e2
        RelationalExpr
e3' <- RelationalExpr -> Either RelationalError RelationalExpr
relExprT RelationalExpr
e3
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
name, RelationalExpr
e1', RelationalExpr
e2', RelationalExpr
e3')
  [(IncDepName, RelationalExpr, RelationalExpr, RelationalExpr)]
notifsData <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}.
(a, RelationalExpr, RelationalExpr, RelationalExpr)
-> Either
     RelationalError (a, RelationalExpr, RelationalExpr, RelationalExpr)
transform (Notifications
-> [(IncDepName, RelationalExpr, RelationalExpr, RelationalExpr)]
notificationsAsData Notifications
notifs)
  let mkRow :: (IncDepName, RelationalExpr, RelationalExpr, RelationalExpr)
-> [Atom]
mkRow (IncDepName
name, RelationalExpr
changeE, RelationalExpr
oldE, RelationalExpr
newE) = [IncDepName -> Atom
TextAtom IncDepName
name,
                                           RelationalExpr -> Atom
RelationalExprAtom RelationalExpr
changeE,
                                           RelationalExpr -> Atom
RelationalExprAtom RelationalExpr
oldE,
                                           RelationalExpr -> Atom
RelationalExprAtom RelationalExpr
newE]
  Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs (forall a b. (a -> b) -> [a] -> [b]
map (IncDepName, RelationalExpr, RelationalExpr, RelationalExpr)
-> [Atom]
mkRow [(IncDepName, RelationalExpr, RelationalExpr, RelationalExpr)]
notifsData)

notificationsAsData :: Notifications -> [(Text, RelationalExpr, RelationalExpr, RelationalExpr)]
notificationsAsData :: Notifications
-> [(IncDepName, RelationalExpr, RelationalExpr, RelationalExpr)]
notificationsAsData Notifications
notifs =
    forall a b. (a -> b) -> [a] -> [b]
map forall {a}.
(a, Notification)
-> (a, RelationalExpr, RelationalExpr, RelationalExpr)
mkRow (forall k a. Map k a -> [(k, a)]
M.toList Notifications
notifs)
  where
    mkRow :: (a, Notification)
-> (a, RelationalExpr, RelationalExpr, RelationalExpr)
mkRow (a
name, Notification
notif) = (a
name,
                           Notification -> RelationalExpr
changeExpr Notification
notif,
                           Notification -> RelationalExpr
reportOldExpr Notification
notif,
                           Notification -> RelationalExpr
reportNewExpr Notification
notif)