git.iko.soy/project-m36
on c3a4e2d help sign in
project-m36/src/lib/ProjectM36/RelationalExpression.hs
944 lines 49 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2module ProjectM36.RelationalExpression where
3import ProjectM36.Relation
4import ProjectM36.Tuple
5import ProjectM36.TupleSet
6import ProjectM36.Base
7import ProjectM36.Error
8import ProjectM36.AtomType
9import ProjectM36.Attribute (emptyAttributes)
10import ProjectM36.ScriptSession
11import ProjectM36.DataTypes.Primitive
12import ProjectM36.AtomFunction
13import ProjectM36.DatabaseContextFunction
14import qualified ProjectM36.Attribute as A
15import qualified Data.Map as M
16import qualified Data.HashSet as HS
17import qualified Data.Set as S
18import Control.Monad.State hiding (join)
19import Control.Exception
20import Data.Maybe
21import Data.Either
22import Data.Char (isUpper)
23import qualified Data.Text as T
24import qualified Data.Vector as V
25import qualified ProjectM36.TypeConstructorDef as TCD
26import Control.Monad.Trans.Except
27import Control.Monad.Trans.Reader
29import GHC
30import GHC.Paths
32data DatabaseContextExprDetails = CountUpdatedTuples
34databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc
35databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups
36 where
37 attrs = A.attributesFromList [Attribute "count" IntAtomType]
38 existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn)
39 existingCount = case V.head (tupleAtoms existingTuple) of
40 IntAtom v -> v
41 _ -> error "impossible counting error in tupleAtoms"
42 newTups = case mkTupleSetFromList attrs [[IntAtom (existingCount + 1)]] of
43 Left err -> error ("impossible counting error in " ++ show err)
44 Right ts -> ts
46-- | Used to start a fresh database state for a new database context expression.
47freshDatabaseState :: DatabaseContext -> DatabaseStateElems
48freshDatabaseState ctx = (ctx, M.empty, False) --future work: propagate return accumulator
50-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
51data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
52 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
53 RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
55instance Show RelationalExprStateElems where
56 show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup
57 show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs
58 show (RelationalExprStateElems _) = "RelationalExprStateElems"
60mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
61mkRelationalExprState = RelationalExprStateElems
63mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
64mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn
65mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st
66mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in
67 RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)
69mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
70mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
71mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
72mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
74type ResultAccumName = StringType
76type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation
78data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,
79 resultAccumResult :: Relation
80 }
82type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)
84type DatabaseState a = State DatabaseStateElems a
86getStateContext :: DatabaseState DatabaseContext
87getStateContext = do
88 (ctx,_, _) <- get
89 pure ctx
91putStateContext :: DatabaseContext -> DatabaseState ()
92putStateContext ctx = do
93 (_, accum, _) <- get
94 put (ctx, accum, True)
96type RelationalExprState a = Reader RelationalExprStateElems a
98stateElemsContext :: RelationalExprStateElems -> DatabaseContext
99stateElemsContext (RelationalExprStateTupleElems ctx _) = ctx
100stateElemsContext (RelationalExprStateElems ctx) = ctx
101stateElemsContext (RelationalExprStateAttrsElems ctx _) = ctx
103setStateElemsContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
104setStateElemsContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
105setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
106setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
108--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
109evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
110evalRelationalExpr (RelationVariable name _) = do
111 relvarTable <- fmap (relationVariables . stateElemsContext) ask
112 return $ case M.lookup name relvarTable of
113 Just res -> Right res
114 Nothing -> Left $ RelVarNotDefinedError name
116evalRelationalExpr (Project attrNames expr) = do
117 eAttrNameSet <- evalAttributeNames attrNames expr
118 case eAttrNameSet of
119 Left err -> pure (Left err)
120 Right attrNameSet -> do
121 rel <- evalRelationalExpr expr
122 case rel of
123 Right rel2 -> pure $ project attrNameSet rel2
124 Left err -> pure $ Left err
126evalRelationalExpr (Union exprA exprB) = do
127 relA <- evalRelationalExpr exprA
128 relB <- evalRelationalExpr exprB
129 case relA of
130 Left err -> return $ Left err
131 Right relA2 -> case relB of
132 Left err -> return $ Left err
133 Right relB2 -> return $ union relA2 relB2
135evalRelationalExpr (Join exprA exprB) = do
136 relA <- evalRelationalExpr exprA
137 relB <- evalRelationalExpr exprB
138 case relA of
139 Left err -> return $ Left err
140 Right relA2 -> case relB of
141 Left err -> return $ Left err
142 Right relB2 -> return $ join relA2 relB2
144evalRelationalExpr (Difference exprA exprB) = do
145 relA <- evalRelationalExpr exprA
146 relB <- evalRelationalExpr exprB
147 case relA of
148 Left err -> return $ Left err
149 Right relA2 -> case relB of
150 Left err -> return $ Left err
151 Right relB2 -> return $ difference relA2 relB2
153evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =
154 case mkRelation attributeSet tupleSet of
155 Right rel -> return $ Right rel
156 Left err -> return $ Left err
158evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
159 currentContext <- fmap stateElemsContext ask
160 let tConss = typeConstructorMapping currentContext
161 -- 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
162 runExceptT $ do
163 mAttrs <- case mAttrExprs of
164 Just _ ->
165 Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs)
166 Nothing -> pure Nothing
167 tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs
168 let attrs = fromMaybe firstTupleAttrs mAttrs
169 firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)
170 either throwE pure (mkRelation attrs (RelationTupleSet tuples))
172evalRelationalExpr (ExistingRelation rel) = pure (Right rel)
174evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
175 evald <- evalRelationalExpr relExpr
176 case evald of
177 Right rel -> return $ rename oldAttrName newAttrName rel
178 Left err -> return $ Left err
180evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do
181 eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr
182 case eOldAttrNameSet of
183 Left err -> pure (Left err)
184 Right oldAttrNameSet -> do
185 evald <- evalRelationalExpr relExpr
186 case evald of
187 Right rel -> return $ group oldAttrNameSet newAttrName rel
188 Left err -> return $ Left err
190evalRelationalExpr (Ungroup attrName relExpr) = do
191 evald <- evalRelationalExpr relExpr
192 case evald of
193 Right rel -> return $ ungroup attrName rel
194 Left err -> return $ Left err
196evalRelationalExpr (Restrict predicateExpr relExpr) = do
197 evald <- evalRelationalExpr relExpr
198 case evald of
199 Left err -> return $ Left err
200 Right rel -> do
201 eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr
202 case eFilterFunc of
203 Left err -> return $ Left err
204 Right filterfunc ->
205 pure (restrict filterfunc rel)
207evalRelationalExpr (Equals relExprA relExprB) = do
208 evaldA <- evalRelationalExpr relExprA
209 evaldB <- evalRelationalExpr relExprB
210 case evaldA of
211 Left err -> return $ Left err
212 Right relA -> case evaldB of
213 Left err -> return $ Left err
214 Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse
216--warning: copy-pasta from above- refactor
217evalRelationalExpr (NotEquals relExprA relExprB) = do
218 evaldA <- evalRelationalExpr relExprA
219 evaldB <- evalRelationalExpr relExprB
220 case evaldA of
221 Left err -> return $ Left err
222 Right relA -> case evaldB of
223 Left err -> return $ Left err
224 Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse
226-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
227evalRelationalExpr (Extend tupleExpression relExpr) = do
228 rstate <- ask
229 let evald = runReader (evalRelationalExpr relExpr) rstate
230 case evald of
231 Left err -> pure (Left err)
232 Right rel -> do
233 tupProc <- extendTupleExpressionProcessor rel tupleExpression
234 case tupProc of
235 Left err -> pure (Left err)
236 Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
238--helper function to process relation variable creation/assignment
239setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ())
240setRelVar relVarName rel = do
241 currentContext <- getStateContext
242 let newRelVars = M.insert relVarName rel $ relationVariables currentContext
243 potentialContext = currentContext { relationVariables = newRelVars }
245 case checkConstraints potentialContext of
246 Left err -> pure (Left err)
247 Right _ -> do
248 putStateContext potentialContext
249 return (Right ())
251-- 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
252deleteRelVar :: RelVarName -> DatabaseState (Either RelationalError ())
253deleteRelVar relVarName = do
254 currContext <- getStateContext
255 let relVars = relationVariables currContext
256 if M.notMember relVarName relVars then
257 pure (Right ())
258 else do
259 let newRelVars = M.delete relVarName relVars
260 newContext = currContext { relationVariables = newRelVars }
261 putStateContext newContext
262 pure (Right ())
264evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ())
265evalDatabaseContextExpr NoOperation = pure (Right ())
267evalDatabaseContextExpr (Define relVarName attrExprs) = do
268 relvars <- fmap relationVariables getStateContext
269 tConss <- fmap typeConstructorMapping getStateContext
270 let eAttrs = map (evalAttrExpr tConss) attrExprs
271 case lefts eAttrs of
272 err:_ -> pure (Left err)
273 [] -> case M.member relVarName relvars of
274 True -> pure (Left (RelVarAlreadyDefinedError relVarName))
275 False -> setRelVar relVarName emptyRelation >> pure (Right ())
276 where
277 attrs = A.attributesFromList (rights eAttrs)
278 emptyRelation = Relation attrs emptyTupleSet
280evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName
282evalDatabaseContextExpr (Assign relVarName expr) = do
283 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
284 context <- getStateContext
285 let existingRelVar = M.lookup relVarName relVarTable
286 relVarTable = relationVariables context
287 value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)
288 case value of
289 Left err -> pure (Left err)
290 Right rel -> case existingRelVar of
291 Nothing -> setRelVar relVarName rel
292 Just existingRel -> let expectedAttributes = attributes existingRel
293 foundAttributes = attributes rel in
294 if A.attributesEqual expectedAttributes foundAttributes then
295 setRelVar relVarName rel
296 else
297 pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes))
299evalDatabaseContextExpr (Insert relVarName relExpr) = do
300 context <- getStateContext
301 let unionexp = Union relExpr rv
302 rv = RelationVariable relVarName ()
303 unioned = runReader (evalRelationalExpr unionexp) (RelationalExprStateElems context)
304 origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
305 case unioned of
306 Left err -> pure (Left err)
307 Right unioned' -> case origRel of
308 Left err -> pure (Left err)
309 Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted
310 pure (Right ())
311 else
312 evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned')
314evalDatabaseContextExpr (Delete relVarName predicate) = do
315 context <- getStateContext
316 let rv = RelationVariable relVarName ()
317 let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context)
318 origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)
319 case updatedRel of
320 Left err -> pure (Left err)
321 Right updatedRel' -> case origRel of
322 Left err -> pure (Left err)
323 Right origRel' -> if cardinality origRel' == cardinality updatedRel' then
324 pure (Right ())
325 else
326 setRelVar relVarName updatedRel'
328--union of restricted+updated portion and the unrestricted+unupdated portion
329evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
330 context <- getStateContext
331 let relVarTable = relationVariables context
332 case M.lookup relVarName relVarTable of
333 Nothing -> pure (Left (RelVarNotDefinedError relVarName))
334 Just rel ->
335 case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
336 Left err -> pure (Left err)
337 Right predicateFunc -> do
338 let ret = do
339 restrictedPortion <- restrict predicateFunc rel
340 if cardinality restrictedPortion == Finite 0 then
341 pure Nothing
342 else do
343 unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel
344 updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
345 updatedRel <- updatedPortion `union` unrestrictedPortion
346 pure (Just updatedRel)
347 case ret of
348 Left err -> pure (Left err)
349 Right Nothing -> pure (Right ())
350 Right (Just updatedRel) -> setRelVar relVarName updatedRel
352evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do
353 currContext <- getStateContext
354 let currDeps = inclusionDependencies currContext
355 newDeps = M.insert newDepName newDep currDeps
356 if M.member newDepName currDeps then
357 pure (Left (InclusionDependencyNameInUseError newDepName))
358 else do
359 let potentialContext = currContext { inclusionDependencies = newDeps }
360 case checkConstraints potentialContext of
361 Left err -> pure (Left err)
362 Right _ -> do
363 putStateContext potentialContext
364 return (Right ())
366evalDatabaseContextExpr (RemoveInclusionDependency depName) = do
367 currContext <- getStateContext
368 let currDeps = inclusionDependencies currContext
369 newDeps = M.delete depName currDeps
370 if M.notMember depName currDeps then
371 pure (Left (InclusionDependencyNameNotInUseError depName))
372 else do
373 putStateContext $ currContext {inclusionDependencies = newDeps }
374 return (Right ())
376-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.
377evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do
378 currentContext <- getStateContext
379 let nots = notifications currentContext
380 if M.member notName nots then
381 pure (Left (NotificationNameInUseError notName))
382 else do
383 let newNotifications = M.insert notName newNotification nots
384 newNotification = Notification { changeExpr = triggerExpr,
385 reportOldExpr = resultOldExpr,
386 reportNewExpr = resultNewExpr}
387 putStateContext $ currentContext { notifications = newNotifications }
388 return (Right ())
390evalDatabaseContextExpr (RemoveNotification notName) = do
391 currentContext <- getStateContext
392 let nots = notifications currentContext
393 if M.notMember notName nots then
394 pure (Left (NotificationNameNotInUseError notName))
395 else do
396 let newNotifications = M.delete notName nots
397 putStateContext $ currentContext { notifications = newNotifications }
398 pure (Right ())
400-- | Adds type and data constructors to the database context.
401-- validate that the type *and* constructor names are unique! not yet implemented!
402evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do
403 currentContext <- getStateContext
404 let oldTypes = typeConstructorMapping currentContext
405 tConsName = TCD.name tConsDef
406 -- validate that the constructor's types exist
407 case validateTypeConstructorDef tConsDef dConsDefList of
408 errs@(_:_) -> pure (Left (someErrors errs))
409 [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))
410 | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))
411 | otherwise -> do
412 let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]
413 putStateContext $ currentContext { typeConstructorMapping = newTypes }
414 pure (Right ())
416-- | 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.
417evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do
418 currentContext <- getStateContext
419 let oldTypes = typeConstructorMapping currentContext
420 if isNothing (findTypeConstructor tConsName oldTypes) then
421 pure (Left (AtomTypeNameNotInUseError tConsName))
422 else do
423 let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes
424 putStateContext $ currentContext { typeConstructorMapping = newTypes }
425 pure (Right ())
427evalDatabaseContextExpr (MultipleExpr exprs) = do
428 --the multiple expressions must pass the same context around- not the old unmodified context
429 evald <- forM exprs evalDatabaseContextExpr
430 --some lifting magic needed here
431 case lefts evald of
432 [] -> pure (Right ())
433 errs -> pure (Left (someErrors errs))
435evalDatabaseContextExpr (RemoveAtomFunction funcName) = do
436 currentContext <- getStateContext
437 let atomFuncs = atomFunctions currentContext
438 case atomFunctionForName funcName atomFuncs of
439 Left err -> pure (Left err)
440 Right realFunc -> if isScriptedAtomFunction realFunc then do
441 let updatedFuncs = HS.delete realFunc atomFuncs
442 putStateContext (currentContext {atomFunctions = updatedFuncs })
443 pure (Right ())
444 else
445 pure (Left (PrecompiledFunctionRemoveError funcName))
447evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do
448 context <- getStateContext
449 let dbcFuncs = dbcFunctions context
450 case databaseContextFunctionForName funcName dbcFuncs of
451 Left err -> pure (Left err)
452 Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do
453 let updatedFuncs = HS.delete realFunc dbcFuncs
454 putStateContext (context { dbcFunctions = updatedFuncs })
455 pure (Right ())
456 else
457 pure (Left (PrecompiledFunctionRemoveError funcName))
459evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
460 context <- getStateContext
461 --resolve atom arguments
462 let relExprState = mkRelationalExprState context
463 eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs
464 eFunc = databaseContextFunctionForName funcName (dbcFunctions context)
465 case eFunc of
466 Left err -> pure (Left err)
467 Right func -> do
468 let expectedArgCount = length (dbcFuncType func)
469 actualArgCount = length atomArgExprs
470 if expectedArgCount /= actualArgCount then
471 pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))
472 else
473 --check that the atom types are valid
474 case lefts eAtomTypes of
475 _:_ -> pure (Left (someErrors (lefts eAtomTypes)))
476 [] -> do
477 let atomTypes = rights eAtomTypes
478 let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
479 Left err -> Just err
480 Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)
481 typeErrors = catMaybes mValidTypes
482 eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
483 if length (lefts eAtomArgs) > 1 then
484 pure (Left (someErrors (lefts eAtomArgs)))
485 else if not (null typeErrors) then
486 pure (Left (someErrors typeErrors))
487 else
488 case evalDatabaseContextFunction func (rights eAtomArgs) context of
489 Left err -> pure (Left err)
490 Right newContext -> putStateContext newContext >> pure (Right ())
492evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
493evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
494 case mScriptSession of
495 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
496 Just scriptSession -> do
497 res <- try $ runGhc (Just libdir) $ do
498 setSession (hscEnv scriptSession)
499 let atomFuncs = atomFunctions currentContext
500 case extractAtomFunctionType funcType of
501 Left err -> pure (Left err)
502 Right adjustedAtomTypeCons -> do
503 --compile the function
504 eCompiledFunc <- compileScript (atomFunctionBodyType scriptSession) script
505 pure $ case eCompiledFunc of
506 Left err -> Left (ScriptError err)
507 Right compiledFunc -> do
508 funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons
509 let updatedFuncs = HS.insert newAtomFunc atomFuncs
510 newContext = currentContext { atomFunctions = updatedFuncs }
511 newAtomFunc = AtomFunction { atomFuncName = funcName,
512 atomFuncType = funcAtomType,
513 atomFuncBody = AtomFunctionBody (Just script) compiledFunc }
514 -- check if the name is already in use
515 if HS.member funcName (HS.map atomFuncName atomFuncs) then
516 Left (FunctionNameInUseError funcName)
517 else
518 Right newContext
519 case res of
520 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
521 Right eContext -> case eContext of
522 Left err -> pure (Left err)
523 Right context' -> pure (Right context')
525evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =
526 case mScriptSession of
527 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
528 Just scriptSession -> do
529 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
530 let last2Args = reverse (take 2 (reverse funcType))
531 atomArgs = take (length funcType - 2) funcType
532 dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]
533 expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"
534 actualType = show funcType
535 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
536 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
537 else do
538 res <- try $ runGhc (Just libdir) $ do
539 setSession (hscEnv scriptSession)
540 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
541 pure $ case eCompiledFunc of
542 Left err -> Left (ScriptError err)
543 Right compiledFunc -> do
544 --if we are here, we have validated that the written function type is X -> DatabaseContext -> DatabaseContext, so we need to munge the first elements into an array
545 funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs
546 let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)
547 newContext = currentContext { dbcFunctions = updatedDBCFuncs }
548 dbcFuncs = dbcFunctions currentContext
549 newDBCFunc = DatabaseContextFunction {
550 dbcFuncName = funcName,
551 dbcFuncType = funcAtomType,
552 dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc
553 }
554 -- check if the name is already in use
555 if HS.member funcName (HS.map dbcFuncName dbcFuncs) then
556 Left (FunctionNameInUseError funcName)
557 else
558 Right newContext
559 case res of
560 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
561 Right eContext -> case eContext of
562 Left err -> pure (Left err)
563 Right context' -> pure (Right context')
564evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do
565 eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
566 case eLoadFunc of
567 Left LoadSymbolError -> pure (Left LoadFunctionError)
568 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
569 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
570 in pure (Right newContext)
571evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do
572 eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
573 case eLoadFunc of
574 Left LoadSymbolError -> pure (Left LoadFunctionError)
575 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
576 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
577 in pure (Right newContext)
579updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
580updateTupleWithAtomExprs exprMap context tupIn = do
581 --resolve all atom exprs
582 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
583 atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
584 pure (attrName, atom)
585 ) (M.toList exprMap)
586 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
588--run verification on all constraints
589checkConstraints :: DatabaseContext -> Either RelationalError ()
590checkConstraints context = do
591 mapM_ (uncurry checkIncDep) (M.toList deps)
592 pure ()
593 where
594 deps = inclusionDependencies context
595 eval expr = evalReader (evalRelationalExpr expr)
596 evalReader f = runReader f (RelationalExprStateElems context)
597 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
598 --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.
599 typeSub <- evalReader (typeForRelationalExpr subsetExpr)
600 typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
601 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
602 let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
603 case eval checkExpr of
604 Left err -> Left err
605 Right resultRel -> if resultRel == relationTrue then
606 pure ()
607 else
608 Left (InclusionDependencyCheckError depName)
610-- 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
611-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
613typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
614typeForRelationalExpr expr = do
615 rstate <- ask
616 let context = stateElemsContext rstate
617 --replace the relationVariables context element with a cloned set of relation devoid of tuples
618 let context' = contextWithEmptyTupleSets context
619 rstate' = setStateElemsContext rstate context'
620 pure (runReader (evalRelationalExpr expr) rstate')
622--returns a database context with all tuples removed
623--this is useful for type checking and optimization
624contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
625contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
626 where
627 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
629liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
630liftE v = do
631 y <- lift v
632 case y of
633 Left err -> throwE err
634 Right val -> pure val
636{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
637predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)
638predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =
639 runExceptT $ do
640 expr1v <- liftE (predicateRestrictionFilter attrs expr1)
641 expr2v <- liftE (predicateRestrictionFilter attrs expr2)
642 pure (\x -> do
643 ev1 <- expr1v x
644 ev2 <- expr2v x
645 pure (ev1 && ev2))
647predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =
648 runExceptT $ do
649 expr1v <- liftE (predicateRestrictionFilter attrs expr1)
650 expr2v <- liftE (predicateRestrictionFilter attrs expr2)
651 pure (\x -> do
652 ev1 <- expr1v x
653 ev2 <- expr2v x
654 pure (ev1 || ev2))
656predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))
658predicateRestrictionFilter attrs (NotPredicate expr) =
659 runExceptT $ do
660 exprv <- liftE (predicateRestrictionFilter attrs expr)
661 pure (fmap not . exprv)
663--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here
664predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
665 rstate <- ask
666 pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of
667 Left err -> Left err
668 Right rel -> if arity rel /= 0 then
669 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
670 else
671 pure (rel == relationTrue)))
673predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
674 rstate <- ask
675 let (attrs', ctxtup') = case rstate of
676 RelationalExprStateElems _ -> (attrs, emptyTuple)
677 RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)
678 RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)
679 runExceptT $ do
680 atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)
681 attr <- either throwE pure $ case A.attributeForName attrName attrs of
682 Right attr -> Right attr
683 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
684 Right ctxattr -> Right ctxattr
685 Left err2@(NoSuchAttributeNamesError _) -> Left err2
686 Left err -> Left err
687 Left err -> Left err
688 if atomExprType /= A.atomType attr then
689 throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
690 else
691 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
692 Right atomCmp -> atomCmp == atomIn
693 Left _ -> False
694 atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate
695 in
696 pure $ case atomForAttributeName attrName tupleIn of
697 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
698 Left _ -> False
699 Right ctxatom -> evalAndCmp ctxatom
700 Left _ -> False
701 Right atomIn -> evalAndCmp atomIn
702-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
703predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
704 --merge attrs into the state attributes
705 rstate <- ask
706 runExceptT $ do
707 aType <- liftE (typeFromAtomExpr attrs atomExpr)
708 if aType /= BoolAtomType then
709 throwE (AtomTypeMismatchError aType BoolAtomType)
710 else
711 pure (\tupleIn ->
712 pure $ case runReader (evalAtomExpr tupleIn atomExpr) rstate of
713 Left _ -> False
714 Right boolAtomValue -> boolAtomValue == BoolAtom True)
716tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
717tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
718 Left (error "SPAMMIT" $ AttributeNameInUseError attrName)
719 else
720 Right rel
722extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
723extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
724 rstate <- ask
725 -- check that the attribute name is not in use
726 case tupleExprCheckNewAttrName newAttrName relIn of
727 Left err -> pure (Left err)
728 Right _ -> runExceptT $ do
729 atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)
730 atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
731 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
732 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
733 pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of
734 Left err -> Left err
735 Right atom -> Right (tupleAtomExtend newAttrName atom tup)
736 )
738evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
739evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
740 Right atom -> pure (Right atom)
741 err@(Left (NoSuchAttributeNamesError _)) -> do
742 rstate <- ask
743 case rstate of
744 RelationalExprStateElems _ -> pure err
745 RelationalExprStateAttrsElems _ _ -> pure err
746 RelationalExprStateTupleElems _ ctxtup -> pure (atomForAttributeName attrName ctxtup)
747 Left err -> pure (Left err)
748evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
749evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
750 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments
751 context <- fmap stateElemsContext ask
752 runExceptT $ do
753 let functions = atomFunctions context
754 func <- either throwE pure (atomFunctionForName funcName functions)
755 let expectedArgCount = length (atomFuncType func) - 1
756 actualArgCount = length argTypes
757 safeInit [_] = []
758 safeInit [] = [] -- different behavior from normal init
759 safeInit (_:xs) = safeInit xs
760 if expectedArgCount /= actualArgCount then
761 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
762 else do
763 mapM_ (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))
764 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
765 case evalAtomFunction func evaldArgs of
766 Left err -> throwE (AtomFunctionUserError err)
767 Right result -> do
768 --validate that the result matches the expected type
769 _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
770 pure result
771evalAtomExpr tupIn (RelationAtomExpr relExpr) = do
772 --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
773 rstate <- ask
774 runExceptT $ do
775 let newState = mergeTuplesIntoRelationalExprState tupIn rstate
776 relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)
777 pure (RelationAtom relAtom)
778evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
779 rstate <- lift ask
780 let newState = mergeTuplesIntoRelationalExprState tupIn rstate
781 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
782 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
783 pure (ConstructedAtom dConsName aType argAtoms)
785typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
786typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
787 rstate <- ask
788 case A.atomTypeForAttributeName attrName attrs of
789 Right aType -> pure (Right aType)
790 Left err@(NoSuchAttributeNamesError _) -> case rstate of
791 RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
792 Left err' -> pure (Left err')
793 Right attr -> pure (Right (A.atomType attr))
794 RelationalExprStateElems _ -> pure (Left err)
795 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
796 Left err' -> pure (Left err')
797 Right atom -> pure (Right (atomTypeForAtom atom))
798 Left err -> pure (Left err)
799typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
800typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
801 context <- fmap stateElemsContext ask
802 let funcs = atomFunctions context
803 case atomFunctionForName funcName funcs of
804 Left err -> pure (Left err)
805 Right func -> do
806 let funcRetType = last (atomFuncType func)
807 funcArgTypes = init (atomFuncType func)
808 eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs
809 case lefts eArgTypes of
810 errs@(_:_) -> pure (Left (someErrors errs))
811 [] -> do
812 let eTvMap = resolveTypeVariables funcArgTypes argTypes
813 argTypes = rights eArgTypes
814 case eTvMap of
815 Left err -> pure (Left err)
816 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
817typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
818 rstate <- lift ask
819 relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
820 pure (RelationAtomType (attributes relType))
821-- grab the type of the data constructor, then validate that the args match the expected types
822typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
823 runExceptT $ do
824 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
825 context <- fmap stateElemsContext (lift ask)
826 either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
828-- | Validate that the type of the AtomExpr matches the expected type.
829verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
830verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
831 rstate <- lift ask
832 case A.atomTypeForAttributeName attrName (attributes relIn) of
833 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
834 (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
835 RelationalExprStateTupleElems _ _ -> throwE err
836 RelationalExprStateElems _ -> throwE err
837 RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
838 Left err' -> throwE err'
839 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
840 Left err -> throwE err
841verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
842verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
843 rstate <- ask
844 let functions = atomFunctions context
845 context = stateElemsContext rstate
846 runExceptT $ do
847 func <- either throwE pure (atomFunctionForName funcName functions)
848 let expectedArgTypes = atomFuncType func
849 funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
850 Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
851 Left err -> throwE err
852 Right x -> pure x
853 ) $ zip3 funcArgExprs expectedArgTypes [1..]
854 if length funcArgTypes /= length expectedArgTypes - 1 then
855 throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
856 else
857 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
858verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
859 rstate <- lift ask
860 relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
861 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
862verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
863 cType <- liftE (typeFromAtomExpr (attributes rel) cons)
864 either throwE pure (atomTypeVerify expectedType cType)
866-- | Look up the type's name and create a new attribute.
867evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
868evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
869 aType <- atomTypeForTypeConstructor tCons aTypes M.empty
870 Right (Attribute attrName aType)
872evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
874evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
875evalTupleExpr attrs (TupleExpr tupMap) = do
876 context <- fmap stateElemsContext ask
877 runExceptT $ do
878 -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority
879 -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed
880 attrAtoms <- mapM (\(attrName, aExpr) -> do
881 newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)
882 newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
883 pure (attrName, newAtom, newAtomType)
884 ) (M.toList tupMap)
885 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
886 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
887 tup = mkRelationTuple tupAttrs atoms
888 tConss = typeConstructorMapping context
889 finalAttrs = fromMaybe tupAttrs attrs
890 --verify that the attributes match
891 when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
892 tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))
893 _ <- either throwE pure (validateTuple tup' tConss)
894 pure tup'
896evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))
897evalAttributeNames attrNames expr = do
898 eExprType <- typeForRelationalExpr expr
899 case eExprType of
900 Left err -> pure (Left err)
901 Right exprTyp -> do
902 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
903 case attrNames of
904 AttributeNames names ->
905 case A.projectionAttributesForNames names (attributes exprTyp) of
906 Left err -> pure (Left err)
907 Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))
909 InvertedAttributeNames names -> do
910 let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
911 if not (S.null nonExistentAttributeNames) then
912 pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
913 else
914 pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))
916 UnionAttributeNames namesA namesB -> do
917 eNameSetA <- evalAttributeNames namesA expr
918 case eNameSetA of
919 Left err -> pure (Left err)
920 Right nameSetA -> do
921 eNameSetB <- evalAttributeNames namesB expr
922 case eNameSetB of
923 Left err -> pure (Left err)
924 Right nameSetB ->
925 pure (Right (S.union nameSetA nameSetB))
927 IntersectAttributeNames namesA namesB -> do
928 eNameSetA <- evalAttributeNames namesA expr
929 case eNameSetA of
930 Left err -> pure (Left err)
931 Right nameSetA -> do
932 eNameSetB <- evalAttributeNames namesB expr
933 case eNameSetB of
934 Left err -> pure (Left err)
935 Right nameSetB ->
936 pure (Right (S.intersection nameSetA nameSetB))
938 RelationalExprAttributeNames attrExpr -> do
939 eAttrExprType <- typeForRelationalExpr attrExpr
940 case eAttrExprType of
941 Left err -> pure (Left err)
942 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))