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