git.iko.soy/project-m36
on 0ff751e help sign in
project-m36/src/lib/ProjectM36/RelationalExpression.hs
1006 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 oldTypes of
434 Left err -> pure (Left err)
435 Right _ | 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 = zipWith
505 (\expType actType
506 -> case atomTypeVerify expType actType of
507 Left err -> Just err
508 Right _ -> Nothing)
509 (dbcFuncType func)
510 atomTypes
511 typeErrors = catMaybes mValidTypes
512 eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
513 if length (lefts eAtomArgs) > 1 then
514 pure (Left (someErrors (lefts eAtomArgs)))
515 else if not (null typeErrors) then
516 pure (Left (someErrors typeErrors))
517 else
518 case evalDatabaseContextFunction func (rights eAtomArgs) context of
519 Left err -> pure (Left err)
520 Right newContext -> putStateContext newContext >> pure (Right ())
522evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
523evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
524 case mScriptSession of
525 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
526 Just scriptSession -> do
527 res <- try $ runGhc (Just libdir) $ do
528 setSession (hscEnv scriptSession)
529 let atomFuncs = atomFunctions currentContext
530 case extractAtomFunctionType funcType of
531 Left err -> pure (Left err)
532 Right adjustedAtomTypeCons -> do
533 --compile the function
534 eCompiledFunc <- compileScript (atomFunctionBodyType scriptSession) script
535 pure $ case eCompiledFunc of
536 Left err -> Left (ScriptError err)
537 Right compiledFunc -> do
538 funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructorValidate False funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons
539 let updatedFuncs = HS.insert newAtomFunc atomFuncs
540 newContext = currentContext { atomFunctions = updatedFuncs }
541 newAtomFunc = AtomFunction { atomFuncName = funcName,
542 atomFuncType = funcAtomType,
543 atomFuncBody = AtomFunctionBody (Just script) compiledFunc }
544 -- check if the name is already in use
545 if HS.member funcName (HS.map atomFuncName atomFuncs) then
546 Left (FunctionNameInUseError funcName)
547 else
548 Right newContext
549 case res of
550 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
551 Right eContext -> case eContext of
552 Left err -> pure (Left err)
553 Right context' -> pure (Right context')
555evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) =
556 case mScriptSession of
557 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
558 Just scriptSession -> do
559 --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
560 let last2Args = reverse (take 2 (reverse funcType))
561 atomArgs = take (length funcType - 2) funcType
562 dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]
563 expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"
564 actualType = show funcType
565 if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then
566 pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
567 else do
568 res <- try $ runGhc (Just libdir) $ do
569 setSession (hscEnv scriptSession)
570 eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
571 pure $ case eCompiledFunc of
572 Left err -> Left (ScriptError err)
573 Right compiledFunc -> do
574 --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
575 funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs
576 let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)
577 newContext = currentContext { dbcFunctions = updatedDBCFuncs }
578 dbcFuncs = dbcFunctions currentContext
579 newDBCFunc = DatabaseContextFunction {
580 dbcFuncName = funcName,
581 dbcFuncType = funcAtomType,
582 dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc
583 }
584 -- check if the name is already in use
585 if HS.member funcName (HS.map dbcFuncName dbcFuncs) then
586 Left (FunctionNameInUseError funcName)
587 else
588 Right newContext
589 case res of
590 Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
591 Right eContext -> case eContext of
592 Left err -> pure (Left err)
593 Right context' -> pure (Right context')
594evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do
595 eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath
596 case eLoadFunc of
597 Left LoadSymbolError -> pure (Left LoadFunctionError)
598 Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }
599 mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)
600 in pure (Right newContext)
601evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do
602 eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath
603 case eLoadFunc of
604 Left LoadSymbolError -> pure (Left LoadFunctionError)
605 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
606 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
607 in pure (Right newContext)
609evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =
610 --Define
611 case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of
612 (Left err,_) -> pure (Left err)
613 (Right (), elems@(ctx,_,_)) -> do
614 --Assign
615 let existingRelVar = M.lookup relVarName relVarTable
616 relVarTable = relationVariables ctx
617 case existingRelVar of
618 Nothing -> pure $ Left (RelVarNotDefinedError relVarName)
619 Just existingRel -> do
620 let expectedAttributes = attributes existingRel
621 let tcMap = typeConstructorMapping ctx
622 eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap
623 case eitherRel of
624 Left err -> pure $ Left err
625 Right rel ->
626 case runState (setRelVar relVarName rel) elems of
627 (Left err,_) -> pure (Left err)
628 (Right (), (ctx',_,_)) -> pure $ Right ctx'
630updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
631updateTupleWithAtomExprs exprMap context tupIn = do
632 --resolve all atom exprs
633 atomsAssoc <- mapM (\(attrName, atomExpr) -> do
634 atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
635 pure (attrName, atom)
636 ) (M.toList exprMap)
637 pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
639--run verification on all constraints
640checkConstraints :: DatabaseContext -> Either RelationalError ()
641checkConstraints context =
642 mapM_ (uncurry checkIncDep) (M.toList deps)
643 where
644 deps = inclusionDependencies context
645 eval expr = evalReader (evalRelationalExpr expr)
646 evalReader f = runReader f (RelationalExprStateElems context)
647 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do
648 --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.
649 typeSub <- evalReader (typeForRelationalExpr subsetExpr)
650 typeSuper <- evalReader (typeForRelationalExpr supersetExpr)
651 when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))
652 let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)
653 case eval checkExpr of
654 Left err -> Left err
655 Right resultRel -> if resultRel == relationTrue then
656 pure ()
657 else
658 Left (InclusionDependencyCheckError depName)
660-- 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
661-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
663typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
664typeForRelationalExpr expr = do
665 rstate <- ask
666 let context = stateElemsContext rstate
667 --replace the relationVariables context element with a cloned set of relation devoid of tuples
668 let context' = contextWithEmptyTupleSets context
669 rstate' = setStateElemsContext rstate context'
670 --evalRelationalExpr could still return an existing relation with tuples, so strip them
671 pure $ case runReader (evalRelationalExpr expr) rstate' of
672 Left err -> Left err
673 Right typeRel -> Right (relationWithEmptyTupleSet typeRel)
675--returns a database context with all tuples removed
676--this is useful for type checking and optimization
677contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext
678contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
679 where
680 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
682liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
683liftE v = do
684 y <- lift v
685 case y of
686 Left err -> throwE err
687 Right val -> pure val
689{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
690predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)
691predicateRestrictionFilter attrs (AndPredicate expr1 expr2) =
692 runExceptT $ do
693 expr1v <- liftE (predicateRestrictionFilter attrs expr1)
694 expr2v <- liftE (predicateRestrictionFilter attrs expr2)
695 pure (\x -> do
696 ev1 <- expr1v x
697 ev2 <- expr2v x
698 pure (ev1 && ev2))
700predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =
701 runExceptT $ do
702 expr1v <- liftE (predicateRestrictionFilter attrs expr1)
703 expr2v <- liftE (predicateRestrictionFilter attrs expr2)
704 pure (\x -> do
705 ev1 <- expr1v x
706 ev2 <- expr2v x
707 pure (ev1 || ev2))
709predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))
711predicateRestrictionFilter attrs (NotPredicate expr) =
712 runExceptT $ do
713 exprv <- liftE (predicateRestrictionFilter attrs expr)
714 pure (fmap not . exprv)
716--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
717predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do
718 rstate <- ask
719 pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of
720 Left err -> Left err
721 Right rel -> if arity rel /= 0 then
722 Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
723 else
724 pure (rel == relationTrue)))
726predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
727 rstate <- ask
728 let (attrs', ctxtup') = case rstate of
729 RelationalExprStateElems _ -> (attrs, emptyTuple)
730 RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)
731 RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)
732 runExceptT $ do
733 atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)
734 attr <- either throwE pure $ case A.attributeForName attrName attrs of
735 Right attr -> Right attr
736 Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of
737 Right ctxattr -> Right ctxattr
738 Left err2@(NoSuchAttributeNamesError _) -> Left err2
739 Left err -> Left err
740 Left err -> Left err
741 if atomExprType /= A.atomType attr then
742 throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
743 else
744 pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of
745 Right atomCmp -> atomCmp == atomIn
746 Left _ -> False
747 atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate
748 in
749 pure $ case atomForAttributeName attrName tupleIn of
750 Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of
751 Left _ -> False
752 Right ctxatom -> evalAndCmp ctxatom
753 Left _ -> False
754 Right atomIn -> evalAndCmp atomIn
755-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
756predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
757 --merge attrs into the state attributes
758 rstate <- ask
759 runExceptT $ do
760 aType <- liftE (typeFromAtomExpr attrs atomExpr)
761 if aType /= BoolAtomType then
762 throwE (AtomTypeMismatchError aType BoolAtomType)
763 else
764 pure (\tupleIn ->
765 case runReader (evalAtomExpr tupleIn atomExpr) rstate of
766 Left err -> Left err
767 Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))
769tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
770tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then
771 Left (AttributeNameInUseError attrName)
772 else
773 Right rel
775extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
776extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
777 rstate <- ask
778 -- check that the attribute name is not in use
779 case tupleExprCheckNewAttrName newAttrName relIn of
780 Left err -> pure (Left err)
781 Right _ -> runExceptT $ do
782 atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)
783 atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
784 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']
785 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
786 pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of
787 Left err -> Left err
788 Right atom -> Right (tupleAtomExtend newAttrName atom tup)
789 )
791evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
792evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of
793 Right atom -> pure (Right atom)
794 err@(Left (NoSuchAttributeNamesError _)) -> do
795 rstate <- ask
796 case rstate of
797 RelationalExprStateElems _ -> pure err
798 RelationalExprStateAttrsElems _ _ -> pure err
799 RelationalExprStateTupleElems _ ctxtup -> pure (atomForAttributeName attrName ctxtup)
800 Left err -> pure (Left err)
801evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
802evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
803 argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments
804 context <- fmap stateElemsContext ask
805 runExceptT $ do
806 let functions = atomFunctions context
807 func <- either throwE pure (atomFunctionForName funcName functions)
808 let expectedArgCount = length (atomFuncType func) - 1
809 actualArgCount = length argTypes
810 safeInit [] = [] -- different behavior from normal init
811 safeInit xs = init xs
812 if expectedArgCount /= actualArgCount then
813 throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)
814 else do
815 let zippedArgs = zip (safeInit (atomFuncType func)) argTypes
816 mapM_ (\(expType, eActType) -> do
817 actType <- either throwE pure eActType
818 either throwE pure (atomTypeVerify expType actType)) zippedArgs
819 evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments
820 case evalAtomFunction func evaldArgs of
821 Left err -> throwE (AtomFunctionUserError err)
822 Right result -> do
823 --validate that the result matches the expected type
824 _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))
825 pure result
826evalAtomExpr tupIn (RelationAtomExpr relExpr) = do
827 --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
828 rstate <- ask
829 runExceptT $ do
830 let newState = mergeTuplesIntoRelationalExprState tupIn rstate
831 relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)
832 pure (RelationAtom relAtom)
833evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
834 rstate <- lift ask
835 let newState = mergeTuplesIntoRelationalExprState tupIn rstate
836 aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
837 argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs
838 pure (ConstructedAtom dConsName aType argAtoms)
840typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
841typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
842 rstate <- ask
843 case A.atomTypeForAttributeName attrName attrs of
844 Right aType -> pure (Right aType)
845 Left err@(NoSuchAttributeNamesError _) -> case rstate of
846 RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
847 Left err' -> pure (Left err')
848 Right attr -> pure (Right (A.atomType attr))
849 RelationalExprStateElems _ -> pure (Left err)
850 RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
851 Left err' -> pure (Left err')
852 Right atom -> pure (Right (atomTypeForAtom atom))
853 Left err -> pure (Left err)
854typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
855typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do
856 context <- fmap stateElemsContext ask
857 let funcs = atomFunctions context
858 case atomFunctionForName funcName funcs of
859 Left err -> pure (Left err)
860 Right func -> do
861 let funcRetType = last (atomFuncType func)
862 funcArgTypes = init (atomFuncType func)
863 eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs
864 case lefts eArgTypes of
865 errs@(_:_) -> pure (Left (someErrors errs))
866 [] -> do
867 let eTvMap = resolveTypeVariables funcArgTypes argTypes
868 argTypes = rights eArgTypes
869 case eTvMap of
870 Left err -> pure (Left err)
871 Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)
872typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
873 rstate <- lift ask
874 relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
875 pure (RelationAtomType (attributes relType))
876-- grab the type of the data constructor, then validate that the args match the expected types
877typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
878 runExceptT $ do
879 argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs
880 context <- fmap stateElemsContext (lift ask)
881 either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
883-- | Validate that the type of the AtomExpr matches the expected type.
884verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
885verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
886 rstate <- lift ask
887 case A.atomTypeForAttributeName attrName (attributes relIn) of
888 Right aType -> either throwE pure (atomTypeVerify expectedType aType)
889 (Left err@(NoSuchAttributeNamesError _)) -> case rstate of
890 RelationalExprStateTupleElems _ _ -> throwE err
891 RelationalExprStateElems _ -> throwE err
892 RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
893 Left err' -> throwE err'
894 Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
895 Left err -> throwE err
896verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
897verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
898 rstate <- ask
899 let functions = atomFunctions context
900 context = stateElemsContext rstate
901 runExceptT $ do
902 func <- either throwE pure (atomFunctionForName funcName functions)
903 let expectedArgTypes = atomFuncType func
904 funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
905 Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
906 Left err -> throwE err
907 Right x -> pure x
908 ) $ zip3 funcArgExprs expectedArgTypes [1..]
909 if length funcArgTypes /= length expectedArgTypes - 1 then
910 throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
911 else
912 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
913verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
914 rstate <- lift ask
915 relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
916 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
917verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do
918 cType <- liftE (typeFromAtomExpr (attributes rel) cons)
919 either throwE pure (atomTypeVerify expectedType cType)
921-- | Look up the type's name and create a new attribute.
922evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
923evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
924 aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty
925 validateAtomType aType aTypes
926 Right (Attribute attrName aType)
928evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
930evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
931evalTupleExpr mAttrs (TupleExpr tupMap) = do
932 context <- fmap stateElemsContext ask
933 runExceptT $ do
934 -- 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
935 -- 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
936 let attrs = fromMaybe A.emptyAttributes mAttrs
937 attrAtoms <- mapM (\(attrName, aExpr) -> do
938 --provided when the relation header is available
939 let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs
940 unresolvedType <- liftE (typeFromAtomExpr attrs aExpr)
941 resolvedType <- case eExpectedAtomType of
942 Left _ -> pure unresolvedType
943 Right typeHint -> either throwE pure (resolveAtomType typeHint unresolvedType)
944 --resolve atom typevars based on resolvedType?
945 newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
946 pure (attrName, newAtom, resolvedType)
947 ) (M.toList tupMap)
948 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
949 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
950 tup = mkRelationTuple tupAttrs atoms
951 tConss = typeConstructorMapping context
952 finalAttrs = fromMaybe tupAttrs mAttrs
953 --verify that the attributes match
954 when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
955 tup' <- either throwE pure (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))
956 _ <- either throwE pure (validateTuple tup' tConss)
957 pure tup'
959evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))
960evalAttributeNames attrNames expr = do
961 eExprType <- typeForRelationalExpr expr
962 case eExprType of
963 Left err -> pure (Left err)
964 Right exprTyp -> do
965 let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))
966 case attrNames of
967 AttributeNames names ->
968 case A.projectionAttributesForNames names (attributes exprTyp) of
969 Left err -> pure (Left err)
970 Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))
972 InvertedAttributeNames names -> do
973 let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet
974 if not (S.null nonExistentAttributeNames) then
975 pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))
976 else
977 pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))
979 UnionAttributeNames namesA namesB -> do
980 eNameSetA <- evalAttributeNames namesA expr
981 case eNameSetA of
982 Left err -> pure (Left err)
983 Right nameSetA -> do
984 eNameSetB <- evalAttributeNames namesB expr
985 case eNameSetB of
986 Left err -> pure (Left err)
987 Right nameSetB ->
988 pure (Right (S.union nameSetA nameSetB))
990 IntersectAttributeNames namesA namesB -> do
991 eNameSetA <- evalAttributeNames namesA expr
992 case eNameSetA of
993 Left err -> pure (Left err)
994 Right nameSetA -> do
995 eNameSetB <- evalAttributeNames namesB expr
996 case eNameSetB of
997 Left err -> pure (Left err)
998 Right nameSetB ->
999 pure (Right (S.intersection nameSetA nameSetB))
1001 RelationalExprAttributeNames attrExpr -> do
1002 eAttrExprType <- typeForRelationalExpr attrExpr
1003 case eAttrExprType of
1004 Left err -> pure (Left err)
1005 Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))