@@ -0,0 +1,93 @@
1+module ProjectM36.IsomorphicSchema where
3+-- isomorphic schemas offer bi-directional functors between two schemas
5+--this should create a new schema
6+data IsomorphSchema = IsoRelVarName RelVarName RelVarName | --maps relvar names between schemas
7+ IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName,RelVarName) | --maps one relvar into two relvars (true, false)
8+ IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName --maps two relvars to one relvar
9+ -- IsoTypeConstructor in morphAttrExpr
12+invert :: IsomorphSchema -> IsomorphSchema
13+invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA
16+-- | Morph a relational expression in one schema to another isomorphic schema.
17+relExprMorph :: IsomorphSchema -> (RelationalExpr -> RelationalExpr)
18+-- wherever nameA is found in the expr, it must be replaced by nameB
19+relExprMorph (IsoRelVarName nameA nameB) = \expr -> case expr of
20+ RelationVariable rv () | rv == nameA -> RelationVariable nameB ()
22+relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \expr -> case expr of
23+ RelationVariable rv () | rv == relIn -> Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ())
25+relExprMorph (IsoUnion (relInT, relInF) _ relTarget) = \expr -> case expr of
26+ RelationVariable rv () | rv == relInT || rv == relInF -> RelationVariable relTarget ()
29+relExprMogrify :: (RelationalExpr -> RelationalExpr) -> RelationalExpr -> RelationalExpr
30+relExprMogrify func (Project attrs expr) = func (Project attrs (func expr))
31+relExprMogrify func (Union exprA exprB) = func (Union (func exprA) (func exprB))
32+relExprMogrify func (Join exprA exprB) = func (Join (func exprA) (func exprB))
33+relExprMogrify func (Rename n1 n2 expr) = func (Rename n1 n2 (func expr))
34+relExprMogrify func (Difference exprA exprB) = func (Difference (func exprA) (func exprB))
35+relExprMogrify func (Group ns n expr) = func (Group ns n (func expr))
36+relExprMogrify func (Ungroup n expr) = func (Ungroup n (func expr))
37+relExprMogrify func (Restrict predi expr) = func (Restrict predi (func expr))
38+relExprMogrify func (Equals exprA exprB) = func (Equals (func exprA) (func exprB))
39+relExprMogrify func (NotEquals exprA exprB) = func (NotEquals (func exprA) (func exprB))
40+relExprMogrify func (Extend ext expr) = func (Extend ext (func expr))
41+relExprMogrify func other = func other
43+spam :: RelationalExpr
44+spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate ("nonboss", "boss"))) (RelationVariable "emp" ())
46+spam2 :: RelationalExpr
47+spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())
49+databaseContextExprMorph :: IsomorphSchema -> (DatabaseContextExpr -> DatabaseContextExpr)
50+databaseContextExprMorph iso@(IsoRelVarName nameA nameB) = \expr -> case expr of
51+ Define rv attrExprs | rv == nameA -> Define nameB attrExprs
52+ Undefine rv | rv == nameA -> Undefine nameB
53+ Assign rv relExpr | rv == nameA -> Assign nameB (relExprF relExpr)
54+ Insert rv relExpr | rv == nameA -> Insert nameB (relExprF relExpr)
55+ Delete rv predi | rv == nameA -> Delete nameB predi -- needs predi mogrifier
56+ Update rv (attrMap) predi | rv == nameA -> Update nameB attrMap predi
59+ relExprF = relExprMogrify (relExprMorph iso)
60+databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) = \expr -> case expr of
61+ Assign rv relExpr | rv == rvIn -> MultipleExpr [
62+ Assign rvTrue (Restrict filt (relExprF relExpr)),
63+ Assign rvFalse (Restrict (NotPredicate filt) (relExprF relExpr))]
64+ Insert rv relExpr | rv == rvIn -> MultipleExpr [
65+ Insert rvTrue (Restrict filt (relExprF relExpr)),
66+ Insert rvFalse (Restrict (NotPredicate filt) (relExprF relExpr))]
67+ Update rv attrMap predi | rv == rvIn -> MultipleExpr [
68+ Update rvTrue attrMap (AndPredicate predi filt),
69+ --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
70+ Update rvFalse attrMap (AndPredicate predi (NotPredicate filt))
71+ --Insert rvFalse (Restrict (NotPredicate filt) (relExprF relExpr))
73+ MultipleExpr exprs -> MultipleExpr (map (databaseContextExprMorph iso) exprs)
76+ relExprF = relExprMogrify (relExprMorph iso)
77+databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) = \expr -> case expr of
78+ --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr
79+ --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?
80+ Assign rv relExpr | rv == rvTrue -> MultipleExpr [Delete rvOut filt,
81+ Insert rvOut (Restrict filt relExpr)]
82+ Assign rv relExpr | rv == rvFalse -> MultipleExpr [Delete rvOut (NotPredicate filt),
83+ Insert rvOut (Restrict (NotPredicate filt) relExpr)]
84+ Insert rv relExpr | rv == rvTrue || rv == rvFalse -> Insert rvOut relExpr
85+ Delete rv delPred | rv == rvTrue -> Delete rvOut (AndPredicate delPred filt)
86+ Delete rv delPred | rv == rvFalse -> Delete rvOut (AndPredicate delPred (NotPredicate filt))
87+ Update rv attrMap predi | rv == rvTrue -> Update rvOut attrMap (AndPredicate predi filt)
88+ Update rv attrMap predi | rv == rvFalse -> Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
90+databaseContextExprMogrify :: (DatabaseContextExpr -> DatabaseContextExpr) -> DatabaseContextExpr -> DatabaseContextExpr
91+databaseContextExprMogrify func (MultipleExpr exprs) = func (MultipleExpr (map func exprs))
92+databaseContextExprMogrify func orig = func orig