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