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