@@ -8,13 +8,16 @@ import GHC.Generics
88import Data.Binary
99import qualified Data.Map as M
1010import qualified Data.Set as S
11+import Debug.Trace
1112-- isomorphic schemas offer bi-directional functors between two schemas
1213
1314--TODO: note that renaming a relvar should alter any stored isomorphisms as well
1415--TODO: rel attrs rename or transform (needs bidirectional atom functions)
16+-- 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)
17+--TODO: allow morphs to stack (morph a schema to a new schema)
18+ -- this could be accomplished by morphing the morphs or by chain linking schemas so that they need not directly reference the underlying concrete schema
1519
1620-- 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
17−--this should create a new schema
1821
1922data SchemaExpr = AddSubschema SchemaName |
2023 AddSubschemaIsomorph SchemaName SchemaIsomorph |
@@ -66,6 +69,21 @@ processRelationalExprInSchema (Schema morphs) relExprIn = do
6669 ex -> relExprMorph morph ex) rexpr
6770
6871 foldM processRelExpr relExprIn morphs
72+
73+processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
74+processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do
75+ let processDbExpr expr morph = case expr of
76+ Assign rv _ | notMember rv -> badRv rv
77+ Insert rv _ | notMember rv -> badRv rv
78+ Update rv _ _ | notMember rv -> badRv rv
79+ MultipleExpr exprs -> MultipleExpr <$> mapM (processDatabaseContextExprInSchema schema) exprs
80+ e -> databaseContextExprMorph morph relExprMogrifier e
81+ relExprMogrifier = processRelationalExprInSchema schema
82+ badRv rv = Left (RelVarNotDefinedError rv)
83+ notMember rv = S.notMember rv validRelVarNames
84+ validRelVarNames = isomorphsInRelVarNames morphs
85+ foldM processDbExpr dbExpr morphs
86+
6987
7088-- | Morph a relational expression in one schema to another isomorphic schema.
7189relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)
@@ -123,10 +141,10 @@ spam2 :: Either RelationalError RelationalExpr
123141spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())
124142-}
125143
126−databaseContextExprMorph :: SchemaIsomorph -> (DatabaseContextExpr -> Either RelationalError DatabaseContextExpr)
127−databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr of
144+databaseContextExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
145+databaseContextExprMorph iso@(IsoRestrict rvIn filt split) relExprFunc expr = case expr of
128146 Assign rv relExpr | rv == rvIn -> do
129− ex <- relExprF relExpr
147+ ex <- relExprFunc relExpr
130148 let trueExpr n = Assign n (Restrict filt ex)
131149 falseExpr n = Assign n (Restrict (NotPredicate filt) ex)
132150 case split of
@@ -135,7 +153,7 @@ databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr
135153 (Nothing, Just rvFalse) -> pure (falseExpr rvFalse)
136154 (Nothing, Nothing) -> Left (RelVarNotDefinedError rvIn)
137155 Insert rv relExpr | rv == rvIn -> do
138− ex <- relExprF relExpr
156+ ex <- relExprFunc relExpr
139157 let trueExpr n = Insert n (Restrict filt ex)
140158 falseExpr n = Insert n (Restrict (NotPredicate filt) ex)
141159 case split of
@@ -152,40 +170,26 @@ databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr
152170 (Just rvTrue, Nothing) -> pure (trueExpr rvTrue)
153171 (Nothing, Just rvFalse) -> pure (falseExpr rvFalse)
154172 (Nothing, Nothing) -> Left (RelVarNotDefinedError rvIn)
155− MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso) exprs
173+ MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
156174 orig -> pure orig
157− where
158− relExprF = relExprMogrify (relExprMorph iso)
159−databaseContextExprMorph iso@(IsoUnion (rvTrue, mRvFalse) filt rvOut) = \expr -> case expr of
175+databaseContextExprMorph iso@(IsoUnion (rvTrue, mRvFalse) filt rvOut) relExprFunc expr = case expr of
160176 --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr
161177 --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?
162− Assign rv relExpr | rv == rvTrue -> relExprF relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,
178+ Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,
163179 Insert rvOut (Restrict filt ex)]
164− Assign rv relExpr | Just rv == mRvFalse -> relExprF relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),
180+ Assign rv relExpr | Just rv == mRvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),
165181 Insert rvOut (Restrict (NotPredicate filt) ex)]
166− Insert rv relExpr | rv == rvTrue || Just rv == mRvFalse -> relExprF relExpr >>= \ex -> pure $ Insert rvOut ex
182+ Insert rv relExpr | rv == rvTrue || Just rv == mRvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex
167183 Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)
168184 Delete rv delPred | Just rv == mRvFalse -> pure $ Delete rvOut (AndPredicate delPred (NotPredicate filt))
169185 Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)
170186 Update rv attrMap predi | Just rv == mRvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
171187 orig -> pure orig
172− where
173− relExprF = relExprMogrify (relExprMorph iso)
174188
175−databaseContextExprMogrify :: (DatabaseContextExpr -> Either RelationalError DatabaseContextExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
176−databaseContextExprMogrify func (MultipleExpr exprs) = do
177− exprs' <- mapM func exprs
178− func (MultipleExpr exprs')
179−databaseContextExprMogrify func orig = func orig
180−
181189-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.
182190applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr
183191applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs
184192
185−-- | Apply the isomorphism transformations to the database context expression to convert the expression from operating on one schema to a disparate, isomorphic schema.
186−applyDatabaseCotextExprSchemaIsomorphs :: SchemaIsomorphs -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
187−applyDatabaseCotextExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> databaseContextExprMogrify (databaseContextExprMorph morph) expr') expr morphs
188−
189193inclusionDependenciesMorph :: SchemaIsomorph -> (InclusionDependency -> Either RelationalError InclusionDependency)
190194inclusionDependenciesMorph iso = \(InclusionDependency subExpr expr) -> InclusionDependency <$> relExprMorph iso subExpr <*> relExprMorph iso expr
191195