git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/src/lib/ProjectM36/IsomorphicSchema.hs
336 lines 20 kB history raw
1{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-}
2module ProjectM36.IsomorphicSchema where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.MiscUtils
6import ProjectM36.RelationalExpression
7import ProjectM36.Relation
8import qualified ProjectM36.AttributeNames as AN
9import Control.Monad
10import Control.Monad.State
11import Control.Monad.Trans.Reader
12import GHC.Generics
13import Data.Binary
14import qualified Data.Map as M
15import qualified Data.Set as S
16import qualified Data.List as L
17import qualified Data.Text as T
18import Data.Monoid
19--import Debug.Trace
20-- isomorphic schemas offer bi-directional functors between two schemas
22--TODO: note that renaming a relvar should alter any stored isomorphisms as well
23--TODO: rel attrs rename or transform (needs bidirectional atom functions)
24-- 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)
25--TODO: allow morphs to stack (morph a schema to a new schema)
26 -- this could be accomplished by morphing the morphs or by chain linking schemas so that they need not directly reference the underlying concrete schema
28-- 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
30data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |
31 RemoveSubschema SchemaName
32 deriving (Generic, Binary, Show)
35isomorphs :: Schema -> SchemaIsomorphs
36isomorphs (Schema i) = i
38-- | Return an error if the schema is not isomorphic to the base database context.
39-- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once.
40--TODO: add relvar must appear exactly once constraint
41validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError
42validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff)
43 | not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes))
44 | not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes))
45 | otherwise = Nothing
46 where
47 --check that the predicate for IsoUnion and IsoRestrict holds right now
48 outDupes = duplicateNames (namesList isomorphOutRelVarNames)
49 inDupes = duplicateNames (namesList isomorphInRelVarNames)
50 duplicateNames = dupes . L.sort
51 namesList isoFunc = concatMap isoFunc (isomorphs potentialSchema)
52 expectedRelVars = M.keysSet (relationVariables baseContext)
53 schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema)
54 rvDiff = S.difference expectedRelVars schemaRelVars
56-- useful for transforming a concrete context into a virtual schema and vice versa
57invert :: SchemaIsomorph -> SchemaIsomorph
58invert (IsoRename rvIn rvOut) = IsoRename rvOut rvIn
59invert (IsoRestrict rvIn predi (rvAOut, rvBOut)) = IsoUnion (rvAOut, rvBOut) predi rvIn
60invert (IsoUnion (rvAIn, rvBIn) predi rvOut) = IsoRestrict rvOut predi (rvAIn, rvBIn)
62isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]
63isomorphInRelVarNames (IsoRestrict rv _ _) = [rv]
64isomorphInRelVarNames (IsoUnion (rvA, rvB) _ _) = [rvA, rvB]
65isomorphInRelVarNames (IsoRename rv _) = [rv]
67-- | Relation variables names represented in the virtual schema space. Useful for determining if a relvar name is valid in the schema.
68isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
69isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
70 where
71 rvnames morph acc = acc ++ isomorphInRelVarNames morph
73isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]
74isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB]
75isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv]
76isomorphOutRelVarNames (IsoRename _ rv) = [rv]
78isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName
79isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
80 where
81 rvnames morph acc = acc ++ isomorphOutRelVarNames morph
83-- | Check that all mentioned relvars are actually present in the current schema.
84validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()
85validateRelationalExprInSchema schema relExprIn = relExprMogrify (\case
86 RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)
87 ex -> Right ex) relExprIn >> pure ()
88 where
89 validRelVarNames = isomorphsInRelVarNames (isomorphs schema)
91processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr
92processRelationalExprInSchema schema relExprIn = do
93 --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)
94 let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr
95 validateRelationalExprInSchema schema relExprIn
96 foldM processRelExpr relExprIn (isomorphs schema)
98validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()
99validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure ()
101processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
102processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do
103 let relExprMogrifier = processRelationalExprInSchema schema
104 --validate that all mentioned relvars are in the valid set
105 _ <- validateDatabaseContextExprInSchema schema dbExpr
106 --perform the morph
107 foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs
109-- | If the database context expression adds or removes a relvar, we need to update the isomorphs to create a passthrough Isomorph.
110processDatabaseContextExprSchemaUpdate :: Schema -> DatabaseContextExpr -> Schema
111processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr of
112 Define rv _ | S.notMember rv validSchemaName -> passthru rv
113 Assign rv _ | S.notMember rv validSchemaName -> passthru rv
114 Undefine rv | S.member rv validSchemaName -> Schema (filter (elem rv . isomorphInRelVarNames) morphs)
115 MultipleExpr exprs -> foldr (flip processDatabaseContextExprSchemaUpdate) schema exprs
116 _ -> schema
117 where
118 validSchemaName = isomorphsInRelVarNames morphs
119 passthru rvname = Schema (morphs ++ [IsoRename rvname rvname])
121processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas
122processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas
124-- 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!
125-- 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.
126 {-
127-- | Convert inclusion dependencies for display in a specific schema.
128applySchemaToInclusionDependencies :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies
129applySchemaToInclusionDependencies (Schema morphs) incDeps =
130 let incDepMorph incDep = --check that the mentioned relvars are in fact in the current schema
131 M.update incDepMorph incDeps
132 -}
134-- | Morph a relational expression in one schema to another isomorphic schema.
135relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)
136relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \case
137 RelationVariable rv () | rv == relIn -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ()))
138 orig -> Right orig
139relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case
140 --only the true predicate portion appears in the virtual schema
141 RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ()))
143 RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))
144 orig -> Right orig
145relExprMorph (IsoRename relIn relOut) = \case
146 RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ())
147 orig -> Right orig
149relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr
150relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex)
151relExprMogrify func (Union exprA exprB) = do
152 exA <- func exprA
153 exB <- func exprB
154 func (Union exA exB)
155relExprMogrify func (Join exprA exprB) = do
156 exA <- func exprA
157 exB <- func exprB
158 func (Join exA exB)
159relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex)
160relExprMogrify func (Difference exprA exprB) = do
161 exA <- func exprA
162 exB <- func exprB
163 func (Difference exA exB)
164relExprMogrify func (Group ns n expr) = func expr >>= \ex -> func (Group ns n ex)
165relExprMogrify func (Ungroup n expr) = func expr >>= \ex -> func (Ungroup n ex)
166relExprMogrify func (Restrict predi expr) = func expr >>= \ex -> func (Restrict predi ex)
167relExprMogrify func (Equals exprA exprB) = do
168 exA <- func exprA
169 exB <- func exprB
170 func (Equals exA exB)
171relExprMogrify func (NotEquals exprA exprB) = do
172 exA <- func exprA
173 exB <- func exprB
174 func (NotEquals exA exB)
175relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)
176relExprMogrify func other = func other
178{-
179spam :: Either RelationalError RelationalExpr
180spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())
182spam2 :: Either RelationalError RelationalExpr
183spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ())
184-}
186databaseContextExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
187databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) relExprFunc expr = case expr of
188 Assign rv relExpr | rv == rvIn -> do
189 ex <- relExprFunc relExpr
190 let trueExpr n = Assign n (Restrict filt ex)
191 falseExpr n = Assign n (Restrict (NotPredicate filt) ex)
192 pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
193 Insert rv relExpr | rv == rvIn -> do
194 ex <- relExprFunc relExpr
195 let trueExpr n = Insert n (Restrict filt ex)
196 falseExpr n = Insert n (Restrict (NotPredicate filt) ex)
197 pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]
198 Update rv attrMap predi | rv == rvIn -> do
199 -- 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
200 let trueExpr n = Update n attrMap (AndPredicate predi filt)
201 falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt))
202 pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])
203 MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
204 orig -> pure orig
205databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of
206 --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr
207 --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?
208 -- if any tuples are filtered out of the insert/assign, we need to simulate a constraint violation
209 Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,
210 Insert rvOut (Restrict filt ex)]
211 Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),
212 Insert rvOut (Restrict (NotPredicate filt) ex)]
213 Insert rv relExpr | rv == rvTrue || rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex
214 Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)
215 Delete rv delPred | rv == rvFalse -> pure $ Delete rvOut (AndPredicate delPred (NotPredicate filt))
216 Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)
217 Update rv attrMap predi | rv == rvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)
218 MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
219 orig -> pure orig
220databaseContextExprMorph iso@(IsoRename relIn relOut) relExprFunc expr = case expr of
221 Assign rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure (Assign relOut ex)
222 Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex
223 Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred
224 Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi
225 MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs
226 orig -> pure orig
228-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.
229applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr
230applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs
232-- the morph must be applied in the opposite direction
233--algorithm: create a relexpr for each relvar in the schema, then replace those rel exprs wherever they appear in the inc dep relexprs
234-- x = x1 union x2
235inclusionDependencyInSchema :: Schema -> InclusionDependency -> Either RelationalError InclusionDependency
236inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do
237 --collect all relvars which appear in the schema
238 let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)
239 rvAssoc <- mapM (\rvIn -> do
240 rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())
241 pure (rvOut, RelationVariable rvIn ())
242 )
243 (S.toList schemaRelVars)
244 let replacer exprOrig = foldM (\expr (find, replace) -> if expr == find then
245 pure replace
246 else
247 pure expr) exprOrig rvAssoc
248 rexprA' <- relExprMogrify replacer rexprA
249 rexprB' <- relExprMogrify replacer rexprB
250 pure (InclusionDependency rexprA' rexprB')
252-- #55 add two virtual constraints for IsoUnion and enforce them before the tuples disappear
253-- this is needed to
254-- also, it's inverse to IsoRestrict which adds two constraints at the base level
255-- for IsoRestrict, consider hiding the two, generated constraints since they can never be thrown in the isomorphic schema
256inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies
257inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)
259relationVariablesInSchema :: Schema -> DatabaseContext -> Either RelationalError RelationVariables
260relationVariablesInSchema schema@(Schema morphs) context = foldM transform M.empty morphs
261 where
262 transform newRvMap morph = do
263 let rvNames = isomorphInRelVarNames morph
264 rvAssocs <- mapM (\rv -> do
265 expr' <- processRelationalExprInSchema schema (RelationVariable rv ())
266 rel <- runReader (evalRelationalExpr expr') (RelationalExprStateElems context)
267 pure (rv, rel)) rvNames
268 pure (M.union newRvMap (M.fromList rvAssocs))
272{-
273proposal
274data DatabaseContext =
275Concrete ...|
276Virtual Isomorphs
277-}
279applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables
280applyRelationVariablesSchemaIsomorphs = undefined
283applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext
284applySchemaIsomorphsToDatabaseContext morphs context = do
285-- incdeps <- inclusionDependen morphs (inclusionDependencies context)
286 relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)
287 pure (context { --inclusionDependencies = incdeps,
288 relationVariables = relvars
289 --atomFunctions = atomfuncs,
290 --notifications = notifs,
291 --typeConstructorMapping = tconsmapping
292 })
294{-
295validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph
296validate morph underlyingRvNames = if S.size invalidRvNames > 0 then
297 Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames)))
298 else
299 Right morph
300 where
301 morphRvNames = S.fromList (isomorphOutRelVarNames morph)
302 invalidRvNames = S.difference morphRvNames underlyingRvNames
303-}
305-- | Create inclusion dependencies mainly for IsoRestrict because the predicate should hold in the base schema.
306createIncDepsForIsomorph :: SchemaName -> SchemaIsomorph -> InclusionDependencies
307createIncDepsForIsomorph sname (IsoRestrict _ predi (rvTrue, rvFalse)) = let
308 newIncDep predicate rv = InclusionDependency (Project AN.empty (Restrict predicate (RelationVariable rv ()))) (ExistingRelation relationTrue)
309 incDepName b = "schema" <> "_" <> sname <> "_" <> T.pack (show b) in
310 M.fromList [(incDepName True, newIncDep predi rvTrue),
311 (incDepName False, newIncDep (NotPredicate predi) rvFalse)]
312createIncDepsForIsomorph _ _ = M.empty
314-- 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
315evalSchemaExpr :: SchemaExpr -> DatabaseContext -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)
316evalSchemaExpr (AddSubschema sname morphs) context sschemas =
317 if M.member sname sschemas then
318 Left (SubschemaNameInUseError sname)
319 else case valid of
320 Just err -> Left (SchemaCreationError err)
321 Nothing ->
322 let newSchemas = M.insert sname newSchema sschemas
323 moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs
324 incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))
325 in
326 case runState (evalDatabaseContextExpr incDepExprs) (context, M.empty, False) of
327 (Left err, _) -> Left err
328 (Right (), (newContext,_,_)) -> pure (newSchemas, newContext) --need to propagate dirty flag here
329 where
330 newSchema = Schema morphs
331 valid = validateSchema newSchema context
332evalSchemaExpr (RemoveSubschema sname) context sschemas = if M.member sname sschemas then
333 pure (M.delete sname sschemas, context)
334 else
335 Left (SubschemaNameNotInUseError sname)