@@ -2,67 +2,23 @@
22module ProjectM36.RelationalExpression where
33import ProjectM36.Relation
44import ProjectM36.Tuple
5−import ProjectM36.TupleSet
65import ProjectM36.Base
76import ProjectM36.Error
87import ProjectM36.AtomType
9−import ProjectM36.AtomFunctionBody
108import ProjectM36.DataTypes.Primitive
119import ProjectM36.AtomFunction
10+import ProjectM36.RelationalExpressionState
11+import ProjectM36.DatabaseContext
1212import qualified ProjectM36.Attribute as A
1313import qualified Data.Map as M
14−import qualified Data.HashSet as HS
14+import qualified Data.Set as S
1515import Control.Monad.State hiding (join)
16−import Control.Exception
1716import Data.Maybe
1817import Data.Either
19−import Data.Char (isUpper)
20−import qualified Data.Text as T
18+
2119import qualified Data.Vector as V
22−import qualified ProjectM36.TypeConstructorDef as TCD
2320import Control.Monad.Trans.Except
2421
25−import GHC
26−import GHC.Paths
27−
28−-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
29−data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
30− RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
31− RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
32−
33−instance Show RelationalExprStateElems where
34− show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup
35− show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs
36− show (RelationalExprStateElems _) = "RelationalExprStateElems"
37−
38−mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
39−mkRelationalExprState ctx = RelationalExprStateElems ctx
40−
41−mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
42−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn
43−mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st
44−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in
45− RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)
46−
47−mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
48−mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
49−mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
50−mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
51−
52−type DatabaseState a = State DatabaseContext a
53−
54−type RelationalExprState a = State RelationalExprStateElems a
55−
56−stateContext :: RelationalExprStateElems -> DatabaseContext
57−stateContext (RelationalExprStateTupleElems ctx _) = ctx
58−stateContext (RelationalExprStateElems ctx) = ctx
59−stateContext (RelationalExprStateAttrsElems ctx _) = ctx
60−
61−setStateContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
62−setStateContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
63−setStateContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
64−setStateContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
65−
6622--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
6723evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
6824evalRelationalExpr (RelationVariable name _) = do
@@ -185,259 +141,6 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
185141 Left err -> pure (Left err)
186142 Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
187143
188−emptyDatabaseContext :: DatabaseContext
189−emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
190− relationVariables = M.empty,
191− atomFunctions = HS.empty,
192− notifications = M.empty,
193− typeConstructorMapping = []
194− }
195−
196−
197−
198−--helper function to process relation variable creation/assignment
199−setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
200−setRelVar relVarName rel = do
201− currentContext <- get
202− let newRelVars = M.insert relVarName rel $ relationVariables currentContext
203− potentialContext = currentContext { relationVariables = newRelVars }
204−
205− case checkConstraints potentialContext of
206− Just err -> return $ Just err
207− Nothing -> do
208− put potentialContext
209− return Nothing
210−
211−-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation
212−deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
213−deleteRelVar relVarName = do
214− currContext <- get
215− let newRelVars = M.delete relVarName (relationVariables currContext)
216− newContext = currContext { relationVariables = newRelVars }
217− put newContext
218− return Nothing
219−
220−evalContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)
221−evalContextExpr NoOperation = pure Nothing
222−
223−evalContextExpr (Define relVarName attrExprs) = do
224− relvars <- liftM relationVariables get
225− tConss <- liftM typeConstructorMapping get
226− let eAttrs = map (evalAttrExpr tConss) attrExprs
227− case lefts eAttrs of
228− err:_ -> pure (Just err)
229− [] -> case M.member relVarName relvars of
230− True -> return (Just (RelVarAlreadyDefinedError relVarName))
231− False -> setRelVar relVarName emptyRelation
232− where
233− attrs = A.attributesFromList (rights eAttrs)
234− emptyRelation = Relation attrs emptyTupleSet
235−
236−evalContextExpr (Undefine relVarName) = do
237− deleteRelVar relVarName
238−
239−evalContextExpr (Assign relVarName expr) = do
240− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
241− context <- get
242− let existingRelVar = M.lookup relVarName relVarTable
243− relVarTable = relationVariables context
244− value = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
245− case value of
246− Left err -> return $ Just err
247− Right rel -> case existingRelVar of
248− Nothing -> setRelVar relVarName rel
249− Just existingRel -> let expectedAttributes = attributes existingRel
250− foundAttributes = attributes rel in
251− if A.attributesEqual expectedAttributes foundAttributes then
252− setRelVar relVarName rel
253− else
254− return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)
255−
256−evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName ()))
257−
258−evalContextExpr (Delete relVarName predicate) = do
259− context <- get
260− let updatedRel = evalState (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)
261− case updatedRel of
262− Left err -> return $ Just err
263− Right rel -> setRelVar relVarName rel
264−
265−--union of restricted+updated portion and the unrestricted+unupdated portion
266−evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
267− context <- get
268− let relVarTable = relationVariables context
269− case M.lookup relVarName relVarTable of
270− Nothing -> return $ Just (RelVarNotDefinedError relVarName)
271− Just rel -> do
272− case evalState (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
273− Left err -> return $ Just err
274− Right predicateFunc -> do
275− case makeUpdatedRel rel of
276− Left err -> return $ Just err
277− Right updatedRel -> setRelVar relVarName updatedRel
278− where
279− makeUpdatedRel relin = do
280− restrictedPortion <- restrict predicateFunc relin
281− unrestrictedPortion <- restrict (not . predicateFunc) relin
282− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
283− union updatedPortion unrestrictedPortion
284−
285−evalContextExpr (AddInclusionDependency newDepName newDep) = do
286− currContext <- get
287− let currDeps = inclusionDependencies currContext
288− newDeps = M.insert newDepName newDep currDeps
289− if M.member newDepName currDeps then
290− return $ Just (InclusionDependencyNameInUseError newDepName)
291− else do
292− let potentialContext = currContext { inclusionDependencies = newDeps }
293− case checkConstraints potentialContext of
294− Just err -> return $ Just err
295− Nothing -> do
296− put potentialContext
297− return Nothing
298−
299−evalContextExpr (RemoveInclusionDependency depName) = do
300− currContext <- get
301− let currDeps = inclusionDependencies currContext
302− newDeps = M.delete depName currDeps
303− if M.notMember depName currDeps then
304− return $ Just (InclusionDependencyNameNotInUseError depName)
305− else do
306− put $ currContext {inclusionDependencies = newDeps }
307− return Nothing
308−
309−-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
310−evalContextExpr (AddNotification notName triggerExpr resultExpr) = do
311− currentContext <- get
312− let nots = notifications currentContext
313− if M.member notName nots then
314− return $ Just (NotificationNameInUseError notName)
315− else do
316− let newNotifications = M.insert notName newNotification nots
317− newNotification = Notification { changeExpr = triggerExpr,
318− reportExpr = resultExpr }
319− put $ currentContext { notifications = newNotifications }
320− return Nothing
321−
322−evalContextExpr (RemoveNotification notName) = do
323− currentContext <- get
324− let nots = notifications currentContext
325− if M.notMember notName nots then
326− return $ Just (NotificationNameNotInUseError notName)
327− else do
328− let newNotifications = M.delete notName nots
329− put $ currentContext { notifications = newNotifications }
330− return Nothing
331−
332−-- | Adds type and data constructors to the database context.
333−-- validate that the type *and* constructor names are unique! not yet implemented!
334−evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
335− currentContext <- get
336− let oldTypes = typeConstructorMapping currentContext
337− tConsName = TCD.name tConsDef
338− -- validate that the constructor's types exist
339− case validateTypeConstructorDef tConsDef dConsDefList of
340− errs@(_:_) -> pure $ Just (someErrors errs)
341− [] -> do
342− if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
343− pure $ Just (InvalidAtomTypeName tConsName)
344− else if isJust (findTypeConstructor tConsName oldTypes) then
345− pure $ Just (AtomTypeNameInUseError tConsName)
346− else do
347− let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
348− put $ currentContext { typeConstructorMapping = newTypes }
349− pure Nothing
350−
351−-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.
352−evalContextExpr (RemoveTypeConstructor tConsName) = do
353− currentContext <- get
354− let oldTypes = typeConstructorMapping currentContext
355− if findTypeConstructor tConsName oldTypes == Nothing then
356− pure $ Just (AtomTypeNameNotInUseError tConsName)
357− else do
358− let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
359− put $ currentContext { typeConstructorMapping = newTypes }
360− pure Nothing
361−
362−evalContextExpr (MultipleExpr exprs) = do
363− --the multiple expressions must pass the same context around- not the old unmodified context
364− evald <- forM exprs evalContextExpr
365− --some lifting magic needed here
366− case catMaybes evald of
367− [] -> return $ Nothing
368− err:_ -> return $ Just err
369−
370−evalContextExpr (RemoveAtomFunction funcName) = do
371− currentContext <- get
372− let atomFuncs = atomFunctions currentContext
373− dudFunc = emptyAtomFunction funcName -- just for lookup in the hashset
374− if HS.member dudFunc atomFuncs then do
375− let updatedFuncs = HS.delete dudFunc atomFuncs
376− put (currentContext {atomFunctions = updatedFuncs })
377− pure Nothing
378− else
379− pure (Just (AtomFunctionNameNotInUseError funcName))
380−
381−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
382−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do
383− case mScriptSession of
384− Nothing -> pure (Left (AtomFunctionBodyScriptError ScriptCompilationDisabledError))
385− Just scriptSession -> do
386− res <- try $ runGhc (Just libdir) $ do
387− setSession (hscEnv scriptSession)
388− let atomFuncs = atomFunctions currentContext
389− --compile the function
390− eCompiledFunc <- compileAtomFunctionScript scriptSession script
391− pure $ case eCompiledFunc of
392− Left err -> Left (AtomFunctionBodyScriptError err)
393− Right compiledFunc -> do
394− funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) funcType
395− let updatedFuncs = HS.insert newAtomFunc atomFuncs
396− newContext = currentContext { atomFunctions = updatedFuncs }
397− newAtomFunc = AtomFunction { atomFuncName = funcName,
398− atomFuncType = funcAtomType,
399− atomFuncBody = AtomFunctionBody (Just script) compiledFunc }
400−
401− -- check if the name is already in use
402− if HS.member funcName (HS.map atomFuncName atomFuncs) then
403− Left (AtomFunctionNameInUseError funcName)
404− else do
405− Right newContext
406− case res of
407− Left (exc :: SomeException) -> pure $ Left (AtomFunctionBodyScriptError (OtherScriptCompilationError (show exc)))
408− Right eContext -> case eContext of
409− Left err -> pure (Left err)
410− Right context' -> pure (Right context')
411−
412−updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
413−updateTupleWithAtomExprs exprMap context tupIn = do
414− --resolve all atom exprs
415− atomsAssoc <- mapM (\(attrName, atomExpr) -> do
416− atom <- evalState (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
417− pure (attrName, atom)
418− ) (M.toList exprMap)
419− pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
420−
421−--run verification on all constraints
422−checkConstraints :: DatabaseContext -> Maybe RelationalError
423−checkConstraints context = case failures of
424− [] -> Nothing
425− l:_ -> Just l
426− where
427− failures = M.elems $ M.mapMaybeWithKey checkIncDep deps
428− deps = inclusionDependencies context
429− eval expr = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
430− checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
431− let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
432− case eval checkExpr of
433− Left err -> Just err
434− Right resultRel -> if resultRel == relationTrue then
435− Nothing
436− else
437− Just $ InclusionDependencyCheckError depName
438−
439−-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing
440−-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
441144
442145typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
443146typeForRelationalExpr expr = do
@@ -448,13 +151,6 @@ typeForRelationalExpr expr = do
448151 rstate' = setStateContext rstate context'
449152 pure (evalState (evalRelationalExpr expr) rstate')
450153
451−--returns a database context with all tuples removed
452−--this is useful for type checking and optimization
453−contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
454−contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
455− where
456− relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
457−
458154liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
459155liftE v = do
460156 y <- lift v
@@ -688,3 +384,55 @@ evalTupleExpr attrs (TupleExpr tupMap) = runExceptT $ do
688384 _ <- either throwE pure (validateTuple tup' tConss)
689385 pure tup'
690386
387+ -- | Return all relation variable names mentioned in the relational expression. This is used by the constraint static optimizer to determine which relvars are relevant.
388+relationVariableNames :: Show a => RelationalExprBase a -> S.Set RelVarName
389+relationVariableNames relExpr = foldRelationalExprs (\names re -> case re of
390+ RelationVariable name _ -> S.insert name names
391+ _ -> names) S.empty relExpr
392+
393+-- | Return all the unit RelationalExprs. This is useful, for example, for finding all mentions of relation
394+foldRelationalExprs :: (b -> RelationalExprBase a -> b) -> b -> RelationalExprBase a -> b
395+foldRelationalExprs func accum expr = case expr of
396+ e@(MakeRelationFromExprs _ tupleExprs) -> foldl func accum (e : concatMap tupleExprRelationalExprs tupleExprs)
397+ e@(MakeStaticRelation _ _) -> folder e []
398+ e@(ExistingRelation _) -> folder e []
399+ e@(RelationVariable _ _) -> folder e []
400+ e@(Project _ expr2) -> folder e [expr2]
401+ e@(Union exprA exprB) -> folder e [exprA, exprB]
402+ e@(Join exprA exprB) -> folder e [exprA, exprB]
403+ e@(Rename _ _ expr2) -> folder e [expr2]
404+ e@(Difference exprA exprB) -> folder e [exprA, exprB]
405+ e@(Group _ _ expr2) -> folder e [expr2]
406+ e@(Ungroup _ expr2) -> folder e [expr2]
407+ e@(Restrict predi expr2) -> folder e (expr2 : restrictionPredicateRelationalExprs predi)
408+ e@(Equals exprA exprB) -> folder e [exprA, exprB]
409+ e@(NotEquals exprA exprB) -> folder e [exprA, exprB]
410+ e@(Extend extendExpr expr2) -> folder e (expr2 : extendTupleRelationalExprs extendExpr)
411+ where
412+ folder e exprs = func (foldl (foldRelationalExprs func) accum exprs) e
413+
414+-- | Scan tupleExpr to return RelationExprs.
415+tupleExprRelationalExprs :: TupleExprBase a -> [RelationalExprBase a]
416+tupleExprRelationalExprs (TupleExpr amap) = concat (map atomExprRelationalExprs (M.elems amap))
417+
418+atomExprRelationalExprs :: AtomExprBase a -> [RelationalExprBase a]
419+atomExprRelationalExprs (FunctionAtomExpr _ exprs _) = concatMap atomExprRelationalExprs exprs
420+atomExprRelationalExprs (RelationAtomExpr expr) = [expr]
421+atomExprRelationalExprs (ConstructedAtomExpr _ exprs _) = concatMap atomExprRelationalExprs exprs
422+atomExprRelationalExprs _ = []
423+
424+restrictionPredicateRelationalExprs :: RestrictionPredicateExprBase a -> [RelationalExprBase a]
425+restrictionPredicateRelationalExprs predi = case predi of
426+ TruePredicate -> []
427+ AndPredicate exprA exprB -> restrictionPredicateRelationalExprs exprA ++ restrictionPredicateRelationalExprs exprB
428+ OrPredicate exprA exprB -> restrictionPredicateRelationalExprs exprA ++ restrictionPredicateRelationalExprs exprB
429+ NotPredicate expr -> restrictionPredicateRelationalExprs expr
430+ RelationalExprPredicate relExpr -> foldRelationalExprs (\acc expr -> expr : acc) [] relExpr
431+ AtomExprPredicate atomExpr -> atomExprRelationalExprs atomExpr
432+ AttributeEqualityPredicate _ atomExpr -> atomExprRelationalExprs atomExpr
433+
434+extendTupleRelationalExprs :: ExtendTupleExprBase a -> [RelationalExprBase a]
435+extendTupleRelationalExprs (AttributeExtendTupleExpr _ atomExpr) = atomExprRelationalExprs atomExpr
436+
437+relvarReferences :: InclusionDependency -> S.Set RelVarName
438+relvarReferences (InclusionDependency super sub) = S.union (relationVariableNames super) (relationVariableNames sub)