@@ -1,108 +1,153 @@
11module ProjectM36.IsomorphicSchema where
22import ProjectM36.Base
3+import ProjectM36.Error
4+import Data.Maybe
5+import Control.Monad
36-- isomorphic schemas offer bi-directional functors between two schemas
47
8+--TODO: note that renaming a relvar should alter any stored isomorphisms as well
59--TODO: rel attrs rename or transform (needs bidirectional atom functions)
610
711-- 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
812--this should create a new schema
9−data SchemaIsomorph = IsoRelVarName RelVarName RelVarName | --maps relvar names between schemas
10− IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName,RelVarName) | --maps one relvar into two relvars (true, false)
11− IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar
13+data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (Maybe RelVarName, Maybe RelVarName) | --maps one relvar into two relvars (true, false), if the false name is Nothing, no relvar in schemaB is created. This is useful for renaming relation variables between schemas or hiding relvars altogether.
14+ IsoUnion (RelVarName, Maybe RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar
1215 -- IsoTypeConstructor in morphAttrExpr
1316
1417type SchemaIsomorphs = [SchemaIsomorph]
1518
19+-- | Return True iff the SchemaIsomorph is fully isomorphic in the sense that it does not represent an isomorphic sub-schema.
20+isFullyIsomorphic :: SchemaIsomorph -> Bool
21+isFullyIsomorphic (IsoRestrict _ _ (a, b)) = isJust a && isJust b
22+isFullyIsomorphic (IsoUnion (_, a) _ _) = isJust a
23+
24+-- | Convenience function which renames a relvar in schemaA to another name in schemaB.
25+isomorphRename :: RelVarName -> RelVarName -> SchemaIsomorph
26+isomorphRename nameA nameB = IsoRestrict nameA TruePredicate (Just nameB, Nothing)
27+
28+isomorphHide :: RelVarName -> SchemaIsomorph
29+isomorphHide nameA = IsoRestrict nameA (NotPredicate TruePredicate) (Nothing, Nothing)
30+
1631{-
1732invert :: SchemaIsomorph -> SchemaIsomorph
1833invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA
1934-}
20−
35+
2136-- | Morph a relational expression in one schema to another isomorphic schema.
22−relExprMorph :: SchemaIsomorph -> (RelationalExpr -> RelationalExpr)
23−-- wherever nameA is found in the expr, it must be replaced by nameB
24−relExprMorph (IsoRelVarName nameA nameB) = \expr -> case expr of
25− RelationVariable rv () | rv == nameA -> RelationVariable nameB ()
26− orig -> orig
27−relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \expr -> case expr of
28− RelationVariable rv () | rv == relIn -> Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ())
29− orig -> orig
30−relExprMorph (IsoUnion (relInT, relInF) _ relTarget) = \expr -> case expr of
31− RelationVariable rv () | rv == relInT || rv == relInF -> RelationVariable relTarget ()
32− orig -> orig
37+relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)
38+relExprMorph (IsoRestrict relIn predi split) = \expr -> case expr of
39+ RelationVariable rv () | rv == relIn -> case split of
40+ -- hide the relvarname
41+ (Nothing, Nothing) -> Left (RelVarNotDefinedError rv)
42+ --simple relvar rename
43+ (Just relOutTrue, Nothing) -> Right (Restrict predi (RelationVariable relOutTrue ()))
44+ --rename but always empty relation- is this useful?
45+ (Nothing, Just relOutFalse) -> Right (Restrict (NotPredicate predi) (RelationVariable relOutFalse ()))
46+ (Just relOutTrue, Just relOutFalse) -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ()))
47+ orig -> Right orig
48+relExprMorph (IsoUnion (relInT, mRelInF) predi relTarget) = \expr -> case expr of
49+ --only the true predicate portion appears in the virtual schema
50+ RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ()))
51+
52+ RelationVariable rv () | Just rv == mRelInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))
53+ orig -> Right orig
3354
34−relExprMogrify :: (RelationalExpr -> RelationalExpr) -> RelationalExpr -> RelationalExpr
35−relExprMogrify func (Project attrs expr) = func (Project attrs (func expr))
36−relExprMogrify func (Union exprA exprB) = func (Union (func exprA) (func exprB))
37−relExprMogrify func (Join exprA exprB) = func (Join (func exprA) (func exprB))
38−relExprMogrify func (Rename n1 n2 expr) = func (Rename n1 n2 (func expr))
39−relExprMogrify func (Difference exprA exprB) = func (Difference (func exprA) (func exprB))
40−relExprMogrify func (Group ns n expr) = func (Group ns n (func expr))
41−relExprMogrify func (Ungroup n expr) = func (Ungroup n (func expr))
42−relExprMogrify func (Restrict predi expr) = func (Restrict predi (func expr))
43−relExprMogrify func (Equals exprA exprB) = func (Equals (func exprA) (func exprB))
44−relExprMogrify func (NotEquals exprA exprB) = func (NotEquals (func exprA) (func exprB))
45−relExprMogrify func (Extend ext expr) = func (Extend ext (func expr))
55+relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr
56+relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex)
57+relExprMogrify func (Union exprA exprB) = do
58+ exA <- func exprA
59+ exB <- func exprB
60+ func (Union exA exB)
61+relExprMogrify func (Join exprA exprB) = do
62+ exA <- func exprA
63+ exB <- func exprB
64+ func (Join exA exB)
65+relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex)
66+relExprMogrify func (Difference exprA exprB) = do
67+ exA <- func exprA
68+ exB <- func exprB
69+ func (Difference exA exB)
70+relExprMogrify func (Group ns n expr) = func expr >>= \ex -> func (Group ns n ex)
71+relExprMogrify func (Ungroup n expr) = func expr >>= \ex -> func (Ungroup n ex)
72+relExprMogrify func (Restrict predi expr) = func expr >>= \ex -> func (Restrict predi ex)
73+relExprMogrify func (Equals exprA exprB) = do
74+ exA <- func exprA
75+ exB <- func exprB
76+ func (Equals exA exB)
77+relExprMogrify func (NotEquals exprA exprB) = do
78+ exA <- func exprA
79+ exB <- func exprB
80+ func (NotEquals exA exB)
81+relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)
4682relExprMogrify func other = func other
4783
48−spam :: RelationalExpr
49−spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate ("nonboss", "boss"))) (RelationVariable "emp" ())
84+spam :: Either RelationalError RelationalExpr
85+spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())
5086
51−spam2 :: RelationalExpr
52−spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())
87+spam2 :: Either RelationalError RelationalExpr
88+spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())
5389
54−databaseContextExprMorph :: SchemaIsomorph -> (DatabaseContextExpr -> DatabaseContextExpr)
55−databaseContextExprMorph iso@(IsoRelVarName nameA nameB) = \expr -> case expr of
56− Define rv attrExprs | rv == nameA -> Define nameB attrExprs
57− Undefine rv | rv == nameA -> Undefine nameB
58− Assign rv relExpr | rv == nameA -> Assign nameB (relExprF relExpr)
59− Insert rv relExpr | rv == nameA -> Insert nameB (relExprF relExpr)
60− Delete rv predi | rv == nameA -> Delete nameB predi -- needs predi mogrifier
61− Update rv (attrMap) predi | rv == nameA -> Update nameB attrMap predi
62− orig -> orig
63− where
64− relExprF = relExprMogrify (relExprMorph iso)
65−databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) = \expr -> case expr of
66− Assign rv relExpr | rv == rvIn -> MultipleExpr [
67− Assign rvTrue (Restrict filt (relExprF relExpr)),
68− Assign rvFalse (Restrict (NotPredicate filt) (relExprF relExpr))]
69− Insert rv relExpr | rv == rvIn -> MultipleExpr [
70− Insert rvTrue (Restrict filt (relExprF relExpr)),
71− Insert rvFalse (Restrict (NotPredicate filt) (relExprF relExpr))]
72− Update rv attrMap predi | rv == rvIn -> MultipleExpr [
73− Update rvTrue attrMap (AndPredicate predi filt),
74− --Insert rvTrue (Restrict predi (relExprF relExpr)), --something missing here, create a function to conver the attr->atom map to a relexpr to insert based on what matches in the existing relation variable
75− Update rvFalse attrMap (AndPredicate predi (NotPredicate filt))
76− --Insert rvFalse (Restrict (NotPredicate filt) (relExprF relExpr))
77− ]
78− MultipleExpr exprs -> MultipleExpr (map (databaseContextExprMorph iso) exprs)
79− orig -> orig
90+databaseContextExprMorph :: SchemaIsomorph -> (DatabaseContextExpr -> Either RelationalError DatabaseContextExpr)
91+databaseContextExprMorph iso@(IsoRestrict rvIn filt split) = \expr -> case expr of
92+ Assign rv relExpr | rv == rvIn -> do
93+ ex <- relExprF relExpr
94+ let trueExpr n = Assign n (Restrict filt ex)
95+ falseExpr n = Assign n (Restrict (NotPredicate filt) ex)
96+ case split of
97+ (Just rvTrue, Just rvFalse) -> pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
98+ (Just rvTrue, Nothing) -> pure (trueExpr rvTrue)
99+ (Nothing, Just rvFalse) -> pure (falseExpr rvFalse)
100+ (Nothing, Nothing) -> Left (RelVarNotDefinedError rvIn)
101+ Insert rv relExpr | rv == rvIn -> do
102+ ex <- relExprF relExpr
103+ let trueExpr n = Insert n (Restrict filt ex)
104+ falseExpr n = Insert n (Restrict (NotPredicate filt) ex)
105+ case split of
106+ (Just rvTrue, Just rvFalse) -> pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
107+ (Just rvTrue, Nothing) -> pure (trueExpr rvTrue)
108+ (Nothing, Just rvFalse) -> pure (falseExpr rvFalse)
109+ (Nothing, Nothing) -> Left (RelVarNotDefinedError rvIn)
110+ Update rv attrMap predi | rv == rvIn -> do
111+--something missing here, create a function to conver the attr->atom map to a relexpr to insert based on what matches in the existing relation variable
112+ let trueExpr n = MultipleExpr [Update n attrMap (AndPredicate predi filt)]
113+ --Insert rvTrue ...
114+ falseExpr n = MultipleExpr [Update n attrMap (AndPredicate predi (NotPredicate filt))]
115+ --Insert rvFalse, retrieve matching tuples based on attrMap
116+ case split of
117+ (Just rvTrue, Just rvFalse) -> pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])
118+ (Just rvTrue, Nothing) -> pure (trueExpr rvTrue)
119+ (Nothing, Just rvFalse) -> pure (falseExpr rvFalse)
120+ (Nothing, Nothing) -> Left (RelVarNotDefinedError rvIn)
121+ MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso) exprs
122+ orig -> pure orig
80123 where
81124 relExprF = relExprMogrify (relExprMorph iso)
82−databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) = \expr -> case expr of
125+databaseContextExprMorph iso@(IsoUnion (rvTrue, mRvFalse) filt rvOut) = \expr -> case expr of
83126 --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr
84127 --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?
85− Assign rv relExpr | rv == rvTrue -> MultipleExpr [Delete rvOut filt,
86− Insert rvOut (Restrict filt (relExprF relExpr))]
87− Assign rv relExpr | rv == rvFalse -> MultipleExpr [Delete rvOut (NotPredicate filt),
88− Insert rvOut (Restrict (NotPredicate filt) (relExprF relExpr))]
89− Insert rv relExpr | rv == rvTrue || rv == rvFalse -> Insert rvOut (relExprF relExpr)
90− Delete rv delPred | rv == rvTrue -> Delete rvOut (AndPredicate delPred filt)
91− Delete rv delPred | rv == rvFalse -> Delete rvOut (AndPredicate delPred (NotPredicate filt))
92− Update rv attrMap predi | rv == rvTrue -> Update rvOut attrMap (AndPredicate predi filt)
93− Update rv attrMap predi | rv == rvFalse -> Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
94− orig -> orig
128+ Assign rv relExpr | rv == rvTrue -> relExprF relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,
129+ Insert rvOut (Restrict filt ex)]
130+ Assign rv relExpr | Just rv == mRvFalse -> relExprF relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),
131+ Insert rvOut (Restrict (NotPredicate filt) ex)]
132+ Insert rv relExpr | rv == rvTrue || Just rv == mRvFalse -> relExprF relExpr >>= \ex -> pure $ Insert rvOut ex
133+ Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)
134+ Delete rv delPred | Just rv == mRvFalse -> pure $ Delete rvOut (AndPredicate delPred (NotPredicate filt))
135+ Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)
136+ Update rv attrMap predi | Just rv == mRvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
137+ orig -> pure orig
95138 where
96139 relExprF = relExprMogrify (relExprMorph iso)
97140
98−databaseContextExprMogrify :: (DatabaseContextExpr -> DatabaseContextExpr) -> DatabaseContextExpr -> DatabaseContextExpr
99−databaseContextExprMogrify func (MultipleExpr exprs) = func (MultipleExpr (map func exprs))
141+databaseContextExprMogrify :: (DatabaseContextExpr -> Either RelationalError DatabaseContextExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
142+databaseContextExprMogrify func (MultipleExpr exprs) = do
143+ exprs' <- mapM func exprs
144+ func (MultipleExpr exprs')
100145databaseContextExprMogrify func orig = func orig
101146
102147-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.
103−applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> RelationalExpr
104−applyRelationalExprSchemaIsomorphs morphs expr = foldl (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs
148+applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr
149+applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs
105150
106151-- | Apply the isomorphism transformations to the database context expression to convert the expression from operating on one schema to a disparate, isomorphic schema.
107−applyDatabaseCotextExprSchemaIsomorphs :: SchemaIsomorphs -> DatabaseContextExpr -> DatabaseContextExpr
108−applyDatabaseCotextExprSchemaIsomorphs morphs expr = foldl (\expr' morph -> databaseContextExprMogrify (databaseContextExprMorph morph) expr') expr morphs
152+applyDatabaseCotextExprSchemaIsomorphs :: SchemaIsomorphs -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
153+applyDatabaseCotextExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> databaseContextExprMogrify (databaseContextExprMorph morph) expr') expr morphs