@@ -2,71 +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
12−import ProjectM36.StaticOptimizer
10+import ProjectM36.RelationalExpressionState
11+import ProjectM36.DatabaseContext
1312import qualified ProjectM36.Attribute as A
1413import qualified Data.Map as M
15−import qualified Data.HashSet as HS
1614import qualified Data.Set as S
1715import Control.Monad.State hiding (join)
18−import Control.Exception
1916import Data.Maybe
2017import Data.Either
21−import Data.Char (isUpper)
22−import qualified Data.Text as T
18+
2319import qualified Data.Vector as V
24−import qualified ProjectM36.TypeConstructorDef as TCD
2520import Control.Monad.Trans.Except
2621
27−import GHC
28−import GHC.Paths
29−
30−import Debug.Trace
31−
32−-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
33−data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
34− RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
35− RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
36−
37−instance Show RelationalExprStateElems where
38− show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup
39− show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs
40− show (RelationalExprStateElems _) = "RelationalExprStateElems"
41−
42−mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
43−mkRelationalExprState ctx = RelationalExprStateElems ctx
44−
45−mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
46−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn
47−mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st
48−mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in
49− RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)
50−
51−mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
52−mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
53−mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
54−mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
55−
56−type DatabaseState a = State DatabaseContext a
57−
58−type RelationalExprState a = State RelationalExprStateElems a
59−
60−stateContext :: RelationalExprStateElems -> DatabaseContext
61−stateContext (RelationalExprStateTupleElems ctx _) = ctx
62−stateContext (RelationalExprStateElems ctx) = ctx
63−stateContext (RelationalExprStateAttrsElems ctx _) = ctx
64−
65−setStateContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
66−setStateContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
67−setStateContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
68−setStateContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
69−
7022--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
7123evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
7224evalRelationalExpr (RelationVariable name _) = do
@@ -189,262 +141,6 @@ evalRelationalExpr (Extend tupleExpression relExpr) = do
189141 Left err -> pure (Left err)
190142 Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
191143
192−emptyDatabaseContext :: DatabaseContext
193−emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
194− relationVariables = M.empty,
195− atomFunctions = HS.empty,
196− notifications = M.empty,
197− typeConstructorMapping = []
198− }
199−
200−
201−
202−--helper function to process relation variable creation/assignment
203−setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError)
204−setRelVar relVarName rel = do
205− currentContext <- get
206− let newRelVars = M.insert relVarName rel $ relationVariables currentContext
207− potentialContext = currentContext { relationVariables = newRelVars }
208−
209− case checkConstraints potentialContext of
210− Just err -> return $ Just err
211− Nothing -> do
212− put potentialContext
213− return Nothing
214−
215−-- 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
216−deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
217−deleteRelVar relVarName = do
218− currContext <- get
219− let newRelVars = M.delete relVarName (relationVariables currContext)
220− newContext = currContext { relationVariables = newRelVars }
221− put newContext
222− return Nothing
223−
224−evalContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)
225−evalContextExpr NoOperation = pure Nothing
226−
227−evalContextExpr (Define relVarName attrExprs) = do
228− relvars <- liftM relationVariables get
229− tConss <- liftM typeConstructorMapping get
230− let eAttrs = map (evalAttrExpr tConss) attrExprs
231− case lefts eAttrs of
232− err:_ -> pure (Just err)
233− [] -> case M.member relVarName relvars of
234− True -> return (Just (RelVarAlreadyDefinedError relVarName))
235− False -> setRelVar relVarName emptyRelation
236− where
237− attrs = A.attributesFromList (rights eAttrs)
238− emptyRelation = Relation attrs emptyTupleSet
239−
240−evalContextExpr (Undefine relVarName) = do
241− deleteRelVar relVarName
242−
243−evalContextExpr (Assign relVarName expr) = do
244− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
245− context <- get
246− let existingRelVar = M.lookup relVarName relVarTable
247− relVarTable = relationVariables context
248− value = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
249− case value of
250− Left err -> return $ Just err
251− Right rel -> case existingRelVar of
252− Nothing -> setRelVar relVarName rel
253− Just existingRel -> let expectedAttributes = attributes existingRel
254− foundAttributes = attributes rel in
255− if A.attributesEqual expectedAttributes foundAttributes then
256− setRelVar relVarName rel
257− else
258− return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes)
259−
260−evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName ()))
261−
262−evalContextExpr (Delete relVarName predicate) = do
263− context <- get
264− let updatedRel = evalState (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)
265− case updatedRel of
266− Left err -> return $ Just err
267− Right rel -> setRelVar relVarName rel
268−
269−--union of restricted+updated portion and the unrestricted+unupdated portion
270−evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
271− context <- get
272− let relVarTable = relationVariables context
273− case M.lookup relVarName relVarTable of
274− Nothing -> return $ Just (RelVarNotDefinedError relVarName)
275− Just rel -> do
276− case evalState (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
277− Left err -> return $ Just err
278− Right predicateFunc -> do
279− case makeUpdatedRel rel of
280− Left err -> return $ Just err
281− Right updatedRel -> setRelVar relVarName updatedRel
282− where
283− makeUpdatedRel relin = do
284− restrictedPortion <- restrict predicateFunc relin
285− unrestrictedPortion <- restrict (not . predicateFunc) relin
286− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
287− union updatedPortion unrestrictedPortion
288−
289−evalContextExpr (AddInclusionDependency newDepName newDep) = do
290− currContext <- get
291− let currDeps = inclusionDependencies currContext
292− newDeps = M.insert newDepName newDep currDeps
293− if M.member newDepName currDeps then
294− return $ Just (InclusionDependencyNameInUseError newDepName)
295− else do
296− let potentialContext = currContext { inclusionDependencies = newDeps }
297− case checkConstraints potentialContext of
298− Just err -> return $ Just err
299− Nothing -> do
300− put potentialContext
301− return Nothing
302−
303−evalContextExpr (RemoveInclusionDependency depName) = do
304− currContext <- get
305− let currDeps = inclusionDependencies currContext
306− newDeps = M.delete depName currDeps
307− if M.notMember depName currDeps then
308− return $ Just (InclusionDependencyNameNotInUseError depName)
309− else do
310− put $ currContext {inclusionDependencies = newDeps }
311− return Nothing
312−
313−-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
314−evalContextExpr (AddNotification notName triggerExpr resultExpr) = do
315− currentContext <- get
316− let nots = notifications currentContext
317− if M.member notName nots then
318− return $ Just (NotificationNameInUseError notName)
319− else do
320− let newNotifications = M.insert notName newNotification nots
321− newNotification = Notification { changeExpr = triggerExpr,
322− reportExpr = resultExpr }
323− put $ currentContext { notifications = newNotifications }
324− return Nothing
325−
326−evalContextExpr (RemoveNotification notName) = do
327− currentContext <- get
328− let nots = notifications currentContext
329− if M.notMember notName nots then
330− return $ Just (NotificationNameNotInUseError notName)
331− else do
332− let newNotifications = M.delete notName nots
333− put $ currentContext { notifications = newNotifications }
334− return Nothing
335−
336−-- | Adds type and data constructors to the database context.
337−-- validate that the type *and* constructor names are unique! not yet implemented!
338−evalContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
339− currentContext <- get
340− let oldTypes = typeConstructorMapping currentContext
341− tConsName = TCD.name tConsDef
342− -- validate that the constructor's types exist
343− case validateTypeConstructorDef tConsDef dConsDefList of
344− errs@(_:_) -> pure $ Just (someErrors errs)
345− [] -> do
346− if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then
347− pure $ Just (InvalidAtomTypeName tConsName)
348− else if isJust (findTypeConstructor tConsName oldTypes) then
349− pure $ Just (AtomTypeNameInUseError tConsName)
350− else do
351− let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
352− put $ currentContext { typeConstructorMapping = newTypes }
353− pure Nothing
354−
355−-- | 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.
356−evalContextExpr (RemoveTypeConstructor tConsName) = do
357− currentContext <- get
358− let oldTypes = typeConstructorMapping currentContext
359− if findTypeConstructor tConsName oldTypes == Nothing then
360− pure $ Just (AtomTypeNameNotInUseError tConsName)
361− else do
362− let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
363− put $ currentContext { typeConstructorMapping = newTypes }
364− pure Nothing
365−
366−evalContextExpr (MultipleExpr exprs) = do
367− --the multiple expressions must pass the same context around- not the old unmodified context
368− evald <- forM exprs evalContextExpr
369− --some lifting magic needed here
370− case catMaybes evald of
371− [] -> return $ Nothing
372− err:_ -> return $ Just err
373−
374−evalContextExpr (RemoveAtomFunction funcName) = do
375− currentContext <- get
376− let atomFuncs = atomFunctions currentContext
377− dudFunc = emptyAtomFunction funcName -- just for lookup in the hashset
378− if HS.member dudFunc atomFuncs then do
379− let updatedFuncs = HS.delete dudFunc atomFuncs
380− put (currentContext {atomFunctions = updatedFuncs })
381− pure Nothing
382− else
383− pure (Just (AtomFunctionNameNotInUseError funcName))
384−
385−evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
386−evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do
387− case mScriptSession of
388− Nothing -> pure (Left (AtomFunctionBodyScriptError ScriptCompilationDisabledError))
389− Just scriptSession -> do
390− res <- try $ runGhc (Just libdir) $ do
391− setSession (hscEnv scriptSession)
392− let atomFuncs = atomFunctions currentContext
393− --compile the function
394− eCompiledFunc <- compileAtomFunctionScript scriptSession script
395− pure $ case eCompiledFunc of
396− Left err -> Left (AtomFunctionBodyScriptError err)
397− Right compiledFunc -> do
398− funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) funcType
399− let updatedFuncs = HS.insert newAtomFunc atomFuncs
400− newContext = currentContext { atomFunctions = updatedFuncs }
401− newAtomFunc = AtomFunction { atomFuncName = funcName,
402− atomFuncType = funcAtomType,
403− atomFuncBody = AtomFunctionBody (Just script) compiledFunc }
404−
405− -- check if the name is already in use
406− if HS.member funcName (HS.map atomFuncName atomFuncs) then
407− Left (AtomFunctionNameInUseError funcName)
408− else do
409− Right newContext
410− case res of
411− Left (exc :: SomeException) -> pure $ Left (AtomFunctionBodyScriptError (OtherScriptCompilationError (show exc)))
412− Right eContext -> case eContext of
413− Left err -> pure (Left err)
414− Right context' -> pure (Right context')
415−
416−updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
417−updateTupleWithAtomExprs exprMap context tupIn = do
418− --resolve all atom exprs
419− atomsAssoc <- mapM (\(attrName, atomExpr) -> do
420− atom <- evalState (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
421− pure (attrName, atom)
422− ) (M.toList exprMap)
423− pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
424−
425−--run verification on all constraints
426−checkConstraints :: DatabaseContext -> Maybe RelationalError
427−checkConstraints context = case optimizedIncDepMap of
428− Left err -> Just err
429− Right filteredIncDepMap -> case failures filteredIncDepMap of
430− [] -> Nothing
431− l -> Just (MultipleErrors l)
432− where
433− optimizedIncDepMap = filterInclusionDependenciesForValidation deps
434− failures incDeps = M.elems $ M.mapMaybeWithKey checkIncDep incDeps
435− deps = inclusionDependencies context
436− eval expr = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
437− checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
438− let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
439− case eval checkExpr of
440− Left err -> Just err
441− Right resultRel -> if resultRel == relationTrue then
442− Nothing
443− else
444− Just $ InclusionDependencyCheckError depName
445−
446−-- 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
447−-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
448144
449145typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
450146typeForRelationalExpr expr = do
@@ -455,13 +151,6 @@ typeForRelationalExpr expr = do
455151 rstate' = setStateContext rstate context'
456152 pure (evalState (evalRelationalExpr expr) rstate')
457153
458−--returns a database context with all tuples removed
459−--this is useful for type checking and optimization
460−contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
461−contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
462− where
463− relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
464−
465154liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
466155liftE v = do
467156 y <- lift v