@@ -1,6 +1,7 @@
11{-# LANGUAGE ScopedTypeVariables #-}
22{-# LANGUAGE FlexibleInstances #-}
33{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE OverloadedStrings #-}
45module ProjectM36.RelationalExpression where
56import ProjectM36.Relation
67import ProjectM36.Tuple
@@ -47,8 +48,6 @@ import Control.Exception
4748import GHC.Paths
4849#endif
4950
50−--import Debug.Trace
51−
5251data DatabaseContextExprDetails = CountUpdatedTuples
5352
5453databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
@@ -110,11 +109,11 @@ askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv
110109askEnv = R.ask
111110
112111mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
113−mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =
114− e{ gre_extra = new_elems }
112+mergeTuplesIntoGraphRefRelationalExprEnv tupIn env =
113+ env { gre_extra = new_elems }
115114 where
116115 new_elems = Just (Left newTuple)
117− mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))
116+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple env))
118117 newTuple = mkRelationTupleFromMap mergedTupMap
119118
120119mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv
@@ -212,160 +211,6 @@ envContext = re_context
212211setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv
213212setEnvContext e ctx = e { re_context = ctx }
214213
215−{-
216−--full evaluation down the graph
217−eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
218−eval expr = do
219− env <- askEnv
220− eGfExpr <- processRelationalExpr expr
221− case eGfExpr of
222− Left err -> pure (Left err)
223− Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)
224−-}
225−{-
226−--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
227−evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)
228−evalRelationalExpr (RelationVariable name _) = do
229− relvarTable <- fmap (relationVariables . envContext) askEnv
230− return $ case M.lookup name relvarTable of
231− Just res -> Right res
232− Nothing -> Left $ RelVarNotDefinedError name
233−
234−evalRelationalExpr (Project attrNames expr) = do
235− eAttrNameSet <- evalAttributeNames attrNames expr
236− case eAttrNameSet of
237− Left err -> pure (Left err)
238− Right attrNameSet -> do
239− rel <- evalRelationalExpr expr
240− case rel of
241− Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)
242− Left err -> pure $ Left err
243−
244−evalRelationalExpr (Union exprA exprB) = do
245− relA <- evalRelationalExpr exprA
246− relB <- evalRelationalExpr exprB
247− case relA of
248− Left err -> return $ Left err
249− Right relA2 -> case relB of
250− Left err -> return $ Left err
251− Right relB2 -> return $ Right (Union relA2 relB2)
252−
253−evalRelationalExpr (Join exprA exprB) = do
254− relA <- evalRelationalExpr exprA
255− relB <- evalRelationalExpr exprB
256− case relA of
257− Left err -> return $ Left err
258− Right relA2 -> case relB of
259− Left err -> return $ Left err
260− Right relB2 -> return $ Right (Join relA2 relB2)
261−
262−evalRelationalExpr (Difference exprA exprB) = do
263− relA <- evalRelationalExpr exprA
264− relB <- evalRelationalExpr exprB
265− case relA of
266− Left err -> return $ Left err
267− Right relA2 -> case relB of
268− Left err -> return $ Left err
269− Right relB2 -> return $ Right (Difference relA2 relB2)
270−
271−evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
272− case mkRelation attributeSet tupleSet of
273− Right rel -> return $ Right (ExistingRelation rel)
274− Left err -> return $ Left err
275−
276−evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
277− currentContext <- fmap envContext askEnv
278− let tConss = typeConstructorMapping currentContext
279− -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible
280− runExceptT $ do
281− mAttrs <- case mAttrExprs of
282− Just _ ->
283− Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)
284− Nothing -> pure Nothing
285− tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
286− let attrs = fromMaybe firstTupleAttrs mAttrs
287− firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
288− expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))
289− pure (ExistingRelation expr)
290−
291−evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))
292−
293−evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
294− evald <- evalRelationalExpr relExpr
295− case evald of
296− Right expr -> return $ Right (Rename oldAttrName newAttrName expr)
297− Left err -> return $ Left err
298−
299−evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
300− eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr
301− case eOldAttrNameSet of
302− Left err -> pure (Left err)
303− Right oldAttrNameSet -> do
304− evald <- evalRelationalExpr relExpr
305− case evald of
306− Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)
307− Left err -> return $ Left err
308−
309−evalRelationalExpr (Ungroup attrName relExpr) = do
310− evald <- evalRelationalExpr relExpr
311− case evald of
312− Right expr -> return $ Right (Ungroup attrName expr)
313− Left err -> return $ Left err
314−
315−evalRelationalExpr (Restrict predicateExpr relExpr) = do
316− evald <- evalRelationalExpr relExpr
317− pred <- processRestrictionPredicateExpr predicateExpr
318− case evald of
319− Left err -> return $ Left err
320− Right expr ->
321− pure $ Right (Restrict pred expr)
322−
323−evalRelationalExpr (Equals relExprA relExprB) = do
324− evaldA <- evalRelationalExpr relExprA
325− evaldB <- evalRelationalExpr relExprB
326− case evaldA of
327− Left err -> return $ Left err
328− Right exprA -> case evaldB of
329− Left err -> return $ Left err
330− Right exprB -> return $ Right (Equals exprA exprB)
331−{-
332−evalRelationalExpr (With views mainExpr) = do
333− rstate <- ask
334−
335− let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then
336− Left (RelVarAlreadyDefinedError vname)
337− else
338− case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of
339− (Left err,_) -> Left err
340− (Right (), (ctx',_,_)) -> Right ctx'
341−
342− case foldM addScopedView (stateElemsContext rstate) views of
343− Left err -> return $ Left err
344− Right ctx'' -> do
345− let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')
346− case evalMainExpr mainExpr of
347− Left err -> return $ Left err
348− Right rel -> return $ Right rel
349−-}
350−--warning: copy-pasta from above- refactor
351−evalRelationalExpr (NotEquals relExprA relExprB) = do
352− evaldA <- evalRelationalExpr relExprA
353− evaldB <- evalRelationalExpr relExprB
354− case evaldA of
355− Left err -> return $ Left err
356− Right exprA -> case evaldB of
357− Left err -> return $ Left err
358− Right exprB -> return $ Right (NotEquals exprA exprB)
359−
360−-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
361−evalRelationalExpr (Extend tupleExpression relExpr) = do
362− eExpr <- evalRelationalExpr relExpr
363− case eExpr of
364− Left err -> pure (Left err)
365− Right expr -> do
366− tupProc <- processExtendTupleExpr tupleExpression
367− pure (Right (Extend tupProc expr))
368−-}
369214--helper function to process relation variable creation/assignment
370215setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()
371216setRelVar relVarName relExpr = do
@@ -465,8 +310,23 @@ evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do
465310--union of restricted+updated portion and the unrestricted+unupdated portion
466311evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do
467312 rvExpr <- relVarByName relVarName
313+ graph <- re_graph <$> dbcRelationalExprEnv
314+ context <- getStateContext
315+ let reEnv = freshGraphRefRelationalExprEnv (Just context) graph
316+ --get the current attributes name in the relvar to ensure that we don't conflict when renaming
317+ eExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr rvExpr)
318+ exprType' <- case eExprType of
319+ Left err -> throwError err
320+ Right t -> pure t
468321 let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr
469− tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict
322+ tmpAttr = tmpAttrC 1
323+ tmpAttrC :: Int -> AttributeName -> AttributeName
324+ tmpAttrC c attr =
325+ let tmpAttrName = "_tmp_" <> T.pack (show c) <> attr in
326+ if tmpAttrName `S.member` A.attributeNameSet (attributes exprType') then
327+ tmpAttrC (c+1) attr
328+ else
329+ tmpAttrName
470330 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)
471331 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)
472332 restrictedPortion = Restrict pred' rvExpr
@@ -780,18 +640,6 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs
780640 Left err -> pure (Left err)
781641 Right dbstate' -> putDBCIOContext (dbc_context dbstate')
782642
783−{-
784−updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple
785−updateTupleWithAtomExprs exprMap context graph tupIn = do
786− --resolve all atom exprs
787− let
788− atomsAssoc <- mapM (\(attrName, atomExpr) -> do
789− let atom = unimplemented
790− --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)
791− pure (attrName, atom)
792− ) (M.toList exprMap)
793− pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
794−-}
795643--run verification on all constraints
796644checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()
797645checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do
@@ -843,15 +691,6 @@ typeForRelationalExpr expr = do
843691 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)
844692 lift $ except runGf
845693
846−--returns a database context with all tuples removed
847−--this is useful for type checking and optimization
848−{-
849−contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
850−contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
851− where
852− relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)
853−-}
854−
855694liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
856695liftE v = do
857696 y <- lift v
@@ -1007,58 +846,6 @@ evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do
1007846 mapM (evalGraphRefAtomExpr tupIn) dConsArgs
1008847 pure (ConstructedAtom dConsName aType argAtoms)
1009848
1010−{-
1011−evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom
1012−evalAtomExpr tupIn expr =
1013− -}
1014−{-
1015−
1016−evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
1017− Right atom -> pure (Right atom)
1018− err@(Left (NoSuchAttributeNamesError _)) -> do
1019− rstate <- ask
1020− let stateTup = stateTuple rstate
1021− pure (atomForAttributeName attrName stateTup)
1022− Left err -> pure (Left err)
1023−evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
1024−evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
1025− argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments
1026− context <- fmap stateElemsContext ask
1027− runExceptT $ do
1028− let functions = atomFunctions context
1029− func <- either throwE pure (atomFunctionForName funcName functions)
1030− let expectedArgCount = length (atomFuncType func) - 1
1031− actualArgCount = length argTypes
1032− safeInit [] = [] -- different behavior from normal init
1033− safeInit xs = init xs
1034− if expectedArgCount /= actualArgCount then
1035− throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
1036− else do
1037− let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
1038− mapM_ (\(expType, eActType) -> do
1039− actType <- either throwE pure eActType
1040− either throwE pure (atomTypeVerify expType actType)) zippedArgs
1041− evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
1042− case evalAtomFunction func evaldArgs of
1043− Left err -> throwE (AtomFunctionUserError err)
1044− Right result -> do
1045− --validate that the result matches the expected type
1046− _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
1047− pure result
1048−evalAtomExpr tupIn (RelationAtomExpr relExpr) = do
1049− --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
1050− rstate <- ask
1051− runExceptT $ do
1052− let newState = mergeTuplesIntoRelationalExprState tupIn rstate
1053− relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)
1054− pure (RelationAtom relAtom)
1055−evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
1056− rstate <- lift ask
1057− let newState = mergeTuplesIntoRelationalExprState tupIn rstate
1058− aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
1059− argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
1060− pure (ConstructedAtom dConsName aType argAtoms)
1061−-}
1062849typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType
1063850typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do
1064851 renv <- askEnv
@@ -1125,7 +912,7 @@ verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) e
1125912 let handler :: RelationalError -> GraphRefRelationalExprM AtomType
1126913 handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)
1127914 handler err = throwError err
1128− verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
915+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler
1129916 funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]
1130917 if length funcArgTypes /= length expectedArgTypes - 1 then
1131918 throwError (AtomTypeCountError funcArgTypes expectedArgTypes)
@@ -1228,56 +1015,6 @@ evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do
12281015-- _ <- lift $ except (validateTuple tup' tConss)
12291016 pure tup'
12301017
1231−{-
1232−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))
1233−evalAttributeNames attrNames expr = do
1234− eExprType <- typeForRelationalExpr expr
1235− case eExprType of
1236− Left err -> throwError err
1237− Right exprTyp -> do
1238− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
1239− case attrNames of
1240− AttributeNames names ->
1241− case A.projectionAttributesForNames names (attributes exprTyp) of
1242− Left err -> pure (Left err)
1243− Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))
1244−
1245− InvertedAttributeNames names -> do
1246− let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
1247− if not (S.null nonExistentAttributeNames) then
1248− pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
1249− else
1250− pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))
1251−
1252− UnionAttributeNames namesA namesB -> do
1253− eNameSetA <- evalAttributeNames namesA expr
1254− case eNameSetA of
1255− Left err -> pure (Left err)
1256− Right nameSetA -> do
1257− eNameSetB <- evalAttributeNames namesB expr
1258− case eNameSetB of
1259− Left err -> pure (Left err)
1260− Right nameSetB ->
1261− pure (Right (S.union nameSetA nameSetB))
1262−
1263− IntersectAttributeNames namesA namesB -> do
1264− eNameSetA <- evalAttributeNames namesA expr
1265− case eNameSetA of
1266− Left err -> pure (Left err)
1267− Right nameSetA -> do
1268− eNameSetB <- evalAttributeNames namesB expr
1269− case eNameSetB of
1270− Left err -> pure (Left err)
1271− Right nameSetB ->
1272− pure (Right (S.intersection nameSetA nameSetB))
1273−
1274− RelationalExprAttributeNames attrExpr -> do
1275− eAttrExprType <- typeForRelationalExpr attrExpr
1276− case eAttrExprType of
1277− Left err -> pure (Left err)
1278− Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))
1279−-}
1280−
12811018--temporary implementation until we have a proper planner+executor
12821019evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation
12831020evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
@@ -1526,15 +1263,6 @@ evalRelationalExpr expr = do
15261263 Left err -> throwError err
15271264 Right rel -> pure rel
15281265
1529−{-
1530−relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr
1531−relVarByName = do
1532− relvars <- relationVariables <$> getStateContext
1533− case M.lookup relVarName relvars of
1534− Nothing -> dbErr (RelVarNotDefinedError relVarName)
1535− Just gfexpr -> pure gfExpr
1536−-}
1537−
15381266class (MonadError RelationalError m, Monad m) => DatabaseContextM m where
15391267 getContext :: m DatabaseContext
15401268