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