@@ -20,15 +20,34 @@ import Data.Char (isUpper)
2020import qualified Data.Text as T
2121import qualified Data.Vector as V
2222import qualified ProjectM36.TypeConstructorDef as TCD
23+import Control.Monad.Trans.Except
2324
2425import GHC
2526import GHC.Paths
2627--import Debug.Trace
2728
29+-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
30+data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
31+ RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
32+ RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
33+type DatabaseState a = State DatabaseContext a
34+
35+type RelationalExprState a = State RelationalExprStateElems a
36+
37+stateContext :: RelationalExprStateElems -> DatabaseContext
38+stateContext (RelationalExprStateTupleElems ctx _) = ctx
39+stateContext (RelationalExprStateAttrsElems ctx _) = ctx
40+stateContext (RelationalExprStateElems ctx) = ctx
41+
42+setStateContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
43+setStateContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
44+setStateContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
45+setStateContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
46+
2847--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
29−evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
48+evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
3049evalRelationalExpr (RelationVariable name _) = do
31− relvarTable <- liftM relationVariables get
50+ relvarTable <- liftM (relationVariables . stateContext) get
3251 return $ case M.lookup name relvarTable of
3352 Just res -> Right res
3453 Nothing -> Left $ RelVarNotDefinedError name
@@ -72,26 +91,20 @@ evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = do
7291 Left err -> return $ Left err
7392
7493evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
75− currentContext <- get
76− tConss <- liftM typeConstructorMapping get
94+ currentContext <- liftM stateContext get
95+ let tConss = typeConstructorMapping currentContext
7796 -- 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
78− let eAttrs = map (evalAttrExpr tConss) (fromMaybe [] mAttrExprs)
79− case lefts eAttrs of
80− [] -> do
81− let mAttrs = case mAttrExprs of
82− Nothing -> Nothing
83− Just _ -> Just (A.attributesFromList (rights eAttrs))
84− eTuples = map (evalTupleExpr currentContext mAttrs) tupleExprs
85− case lefts eTuples of
86− [] -> do
87− let attrs = fromMaybe firstTupleAttrs mAttrs
88− tupList = rights eTuples
89− firstTupleAttrs = if length tupList == 0 then A.emptyAttributes else tupleAttributes (head tupList)
90− pure $ mkRelation attrs (RelationTupleSet tupList)
91− errs -> pure $ Left (someErrors errs)
92− errs -> pure $ Left (someErrors errs)
97+ runExceptT $ do
98+ attrs <- mapM (\expr -> either throwE pure (evalAttrExpr tConss expr)) (fromMaybe [] mAttrExprs)
99+ let mAttrs = case mAttrExprs of
100+ Nothing -> Nothing
101+ Just _ -> Just (A.attributesFromList attrs)
102+ tuples <- mapM (\expr -> liftE (evalTupleExpr mAttrs expr)) tupleExprs
103+ let attrs = fromMaybe firstTupleAttrs mAttrs
104+ firstTupleAttrs = if length tuples == 0 then A.emptyAttributes else tupleAttributes (head tuples)
105+ either throwE pure (mkRelation attrs (RelationTupleSet tuples))
93106
94−evalRelationalExpr (ExistingRelation rel) = return (Right rel)
107+evalRelationalExpr (ExistingRelation rel) = pure (Right rel)
95108
96109evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
97110 evald <- evalRelationalExpr relExpr
@@ -113,12 +126,13 @@ evalRelationalExpr (Ungroup attrName relExpr) = do
113126
114127evalRelationalExpr (Restrict predicateExpr relExpr) = do
115128 evald <- evalRelationalExpr relExpr
116− context <- get
117129 case evald of
118130 Left err -> return $ Left err
119− Right rel -> case predicateRestrictionFilter context (attributes rel) predicateExpr of
120− Left err -> return $ Left err
121− Right filterfunc -> return $ restrict filterfunc rel
131+ Right rel -> do
132+ eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr
133+ case eFilterFunc of
134+ Left err -> return $ Left err
135+ Right filterfunc -> return $ restrict filterfunc rel
122136
123137evalRelationalExpr (Equals relExprA relExprB) = do
124138 evaldA <- evalRelationalExpr relExprA
@@ -141,14 +155,15 @@ evalRelationalExpr (NotEquals relExprA relExprB) = do
141155
142156-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
143157evalRelationalExpr (Extend tupleExpression relExpr) = do
144− evald <- evalRelationalExpr relExpr
145− context <- get
158+ state <- get
159+ let evald = evalState (evalRelationalExpr relExpr) state
146160 case evald of
147161 Left err -> return $ Left err
148162 Right rel -> do
149− case extendTupleExpressionProcessor rel tupleExpression context of
150− Left err -> return $ Left err
151− Right (newAttrs, tupProc) -> return $ relMogrify tupProc newAttrs rel
163+ tupProc <- extendTupleExpressionProcessor rel tupleExpression
164+ case tupProc of
165+ Left err -> pure (Left err)
166+ Right (newAttrs, tupProc) -> pure $ relMogrify tupProc newAttrs rel
152167
153168emptyDatabaseContext :: DatabaseContext
154169emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
@@ -166,6 +181,7 @@ setRelVar relVarName rel = do
166181 currentContext <- get
167182 let newRelVars = M.insert relVarName rel $ relationVariables currentContext
168183 potentialContext = currentContext { relationVariables = newRelVars }
184+
169185 case checkConstraints potentialContext of
170186 Just err -> return $ Just err
171187 Nothing -> do
@@ -175,9 +191,10 @@ setRelVar relVarName rel = do
175191-- 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
176192deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)
177193deleteRelVar relVarName = do
178− currcontext <- get
179− let newRelVars = M.delete relVarName (relationVariables currcontext)
180− put $ currcontext { relationVariables = newRelVars }
194+ currContext <- get
195+ let newRelVars = M.delete relVarName (relationVariables currContext)
196+ newContext = currContext { relationVariables = newRelVars }
197+ put newContext
181198 return Nothing
182199
183200evalContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)
@@ -201,9 +218,10 @@ evalContextExpr (Undefine relVarName) = do
201218
202219evalContextExpr (Assign relVarName expr) = do
203220 -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
204− relVarTable <- liftM relationVariables get
221+ context <- get
205222 let existingRelVar = M.lookup relVarName relVarTable
206− value <- evalRelationalExpr expr
223+ relVarTable = relationVariables context
224+ value = evalState (evalRelationalExpr expr) (RelationalExprStateElems context)
207225 case value of
208226 Left err -> return $ Just err
209227 Right rel -> case existingRelVar of
@@ -217,9 +235,9 @@ evalContextExpr (Assign relVarName expr) = do
217235
218236evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName ()))
219237
220−--assign empty rel until restriction is implemented
221238evalContextExpr (Delete relVarName predicate) = do
222− updatedRel <- evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))
239+ context <- get
240+ let updatedRel = evalState (evalRelationalExpr (Restrict (NotPredicate predicate) (RelationVariable relVarName ()))) (RelationalExprStateElems context)
223241 case updatedRel of
224242 Left err -> return $ Just err
225243 Right rel -> setRelVar relVarName rel
@@ -230,18 +248,19 @@ evalContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do
230248 let relVarTable = relationVariables context
231249 case M.lookup relVarName relVarTable of
232250 Nothing -> return $ Just (RelVarNotDefinedError relVarName)
233− Just rel -> case predicateRestrictionFilter context (attributes rel) restrictionPredicateExpr of
234− Left err -> return $ Just err
235− Right predicateFunc -> do
236− case makeUpdatedRel rel of
237− Left err -> return $ Just err
238− Right updatedRel -> setRelVar relVarName updatedRel
239− where
240− makeUpdatedRel relin = do
241− restrictedPortion <- restrict predicateFunc relin
242− unrestrictedPortion <- restrict (not . predicateFunc) relin
243− updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
244− union updatedPortion unrestrictedPortion
251+ Just rel -> do
252+ case evalState (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of
253+ Left err -> return $ Just err
254+ Right predicateFunc -> do
255+ case makeUpdatedRel rel of
256+ Left err -> return $ Just err
257+ Right updatedRel -> setRelVar relVarName updatedRel
258+ where
259+ makeUpdatedRel relin = do
260+ restrictedPortion <- restrict predicateFunc relin
261+ unrestrictedPortion <- restrict (not . predicateFunc) relin
262+ updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion
263+ union updatedPortion unrestrictedPortion
245264
246265evalContextExpr (AddInclusionDependency newDepName newDep) = do
247266 currContext <- get
@@ -373,11 +392,11 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam
373392updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
374393updateTupleWithAtomExprs exprMap context tupIn = do
375394 --resolve all atom exprs
376− let (errors, atoms) = M.mapEither (evalAtomExpr tupIn context) exprMap
377− if length errors > 0 then
378− Left (MultipleErrors (M.elems errors))
379− else
380− Right (updateTupleWithAtoms atoms tupIn)
395+ atomsAssoc <- mapM (\(attrName, atomExpr) -> do
396+ atom <- evalState (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)
397+ pure (attrName, atom)
398+ ) (M.toList exprMap)
399+ pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)
381400
382401--run verification on all constraints
383402checkConstraints :: DatabaseContext -> Maybe RelationalError
@@ -387,7 +406,7 @@ checkConstraints context = case failures of
387406 where
388407 failures = M.elems $ M.mapMaybeWithKey checkIncDep deps
389408 deps = inclusionDependencies context
390− eval expr = runState (evalRelationalExpr expr) context
409+ eval expr = runState (evalRelationalExpr expr) (RelationalExprStateElems context)
391410 checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = case evaldSub of
392411 (Left err, _) -> Just err
393412 (Right relSub, _) -> case evaldSuper of
@@ -417,12 +436,14 @@ checkConstraint (InclusionDependency name subDep superDep) = do
417436-- 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
418437-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation
419438
420−typeForRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
439+typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
421440typeForRelationalExpr expr = do
422− currstate <- get
441+ state <- get
442+ let context = stateContext state
423443 --replace the relationVariables context element with a cloned set of relation devoid of tuples
424− put $ contextWithEmptyTupleSets currstate
425− evalRelationalExpr expr
444+ let context' = contextWithEmptyTupleSets context
445+ state' = setStateContext state context'
446+ pure (evalState (evalRelationalExpr expr) state')
426447
427448--returns a database context with all tuples removed
428449--this is useful for type checking and optimization
@@ -431,55 +452,71 @@ contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }
431452 where
432453 relVars = M.map (\rel -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)
433454
455+liftE :: (Monad m) => m (Either a b) -> ExceptT a m b
456+liftE v = do
457+ y <- lift v
458+ case y of
459+ Left err -> throwE err
460+ Right val -> pure val
461+
434462{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}
435−predicateRestrictionFilter :: DatabaseContext -> Attributes -> RestrictionPredicateExpr -> Either RelationalError (RelationTuple -> Bool)
436−predicateRestrictionFilter context attrs (AndPredicate expr1 expr2) = do
437− expr1v <- predicateRestrictionFilter context attrs expr1
438− expr2v <- predicateRestrictionFilter context attrs expr2
439− return $ \x -> expr1v x && expr2v x
440−
441−predicateRestrictionFilter context attrs (OrPredicate expr1 expr2) = do
442− expr1v <- predicateRestrictionFilter context attrs expr1
443− expr2v <- predicateRestrictionFilter context attrs expr2
444− return $ \x -> expr1v x || expr2v x
445−
446−predicateRestrictionFilter _ _ TruePredicate = Right $ \_ -> True
447−
448−predicateRestrictionFilter context attrs (NotPredicate expr) = do
449− exprv <- predicateRestrictionFilter context attrs expr
450− return $ \x -> not (exprv x)
451−
452−predicateRestrictionFilter context _ (RelationalExprPredicate relExpr) = case runState (evalRelationalExpr relExpr) context of
453− (Left err, _) -> Left err
454− (Right rel, _) -> if rel == relationTrue then
455− Right $ \_ -> True
456− else if rel == relationFalse then
457− Right $ \_ -> False
458− else
459− Left $ PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'"
460−
461−predicateRestrictionFilter context attrs (AttributeEqualityPredicate attrName atomExpr) = do
462− attr <- A.attributeForName attrName attrs
463− atomExprType <- typeFromAtomExpr attrs context atomExpr
464− if atomExprType /= A.atomType attr then
465− Left $ TupleAttributeTypeMismatchError (A.attributesFromList [attr])
466− else
467− Right $ \tupleIn -> case atomForAttributeName attrName tupleIn of
468− Left _ -> False
469− Right atomIn ->
470− case evalAtomExpr tupleIn context atomExpr of
471− Left _ -> False
472− Right atomCmp -> atomCmp == atomIn
463+predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError (RelationTuple -> Bool))
464+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do
465+ runExceptT $ do
466+ expr1v <- liftE (predicateRestrictionFilter attrs expr1)
467+ expr2v <- liftE (predicateRestrictionFilter attrs expr2)
468+ pure (\x -> expr1v x && expr2v x)
469+
470+predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do
471+ runExceptT $ do
472+ expr1v <- liftE (predicateRestrictionFilter attrs expr1)
473+ expr2v <- liftE (predicateRestrictionFilter attrs expr2)
474+ pure (\x -> expr1v x || expr2v x)
475+
476+predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> True))
477+
478+predicateRestrictionFilter attrs (NotPredicate expr) = do
479+ runExceptT $ do
480+ exprv <- liftE (predicateRestrictionFilter attrs expr)
481+ pure (\x -> not (exprv x))
482+
483+predicateRestrictionFilter attrs (RelationalExprPredicate relExpr) = runExceptT $ do
484+ rel <- liftE (evalRelationalExpr relExpr)
485+ if rel == relationTrue then
486+ pure (\_ -> True)
487+ else if rel == relationFalse then
488+ pure (\_ -> False)
489+ else
490+ throwE (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
491+
492+predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
493+ state <- get
494+ runExceptT $ do
495+ atomExprType <- liftE (typeFromAtomExpr attrs atomExpr)
496+ attr <- either throwE pure (A.attributeForName attrName attrs)
497+ if atomExprType /= A.atomType attr then
498+ throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))
499+ else
500+ pure $ \tupleIn -> case atomForAttributeName attrName tupleIn of
501+ Left _ -> False
502+ Right atomIn ->
503+ let atomEvald = evalState (evalAtomExpr tupleIn atomExpr) state in
504+ case atomEvald of
505+ Left _ -> False
506+ Right atomCmp -> atomCmp == atomIn
473507
474508-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
475−predicateRestrictionFilter context attrs (AtomExprPredicate atomExpr) = do
476− aType <- typeFromAtomExpr attrs context atomExpr
477− if aType /= BoolAtomType then
478− Left $ AtomTypeMismatchError aType BoolAtomType
479− else
480− Right (\tupleIn -> case evalAtomExpr tupleIn context atomExpr of
481− Left _ -> False
482− Right boolAtomValue -> boolAtomValue == BoolAtom True)
509+predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
510+ state <- get
511+ runExceptT $ do
512+ aType <- liftE (typeFromAtomExpr attrs atomExpr)
513+ if aType /= BoolAtomType then
514+ throwE (AtomTypeMismatchError aType BoolAtomType)
515+ else
516+ pure (\tupleIn -> do
517+ case evalState (evalAtomExpr tupleIn atomExpr) state of
518+ Left _ -> False
519+ Right boolAtomValue -> boolAtomValue == BoolAtom True)
483520
484521tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation
485522tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName rel then
@@ -487,87 +524,99 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName
487524 else
488525 Right rel
489526
490−extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> DatabaseContext -> Either RelationalError (Attributes, RelationTuple -> RelationTuple)
491−extendTupleExpressionProcessor relIn
492− (AttributeExtendTupleExpr newAttrName atomExpr) context = do
493− _ <- tupleExprCheckNewAttrName newAttrName relIn
494− atomExprType <- typeFromAtomExpr (attributes relIn) context atomExpr
495− _ <- verifyAtomExprTypes relIn context atomExpr atomExprType
496− let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]
497− newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
498− return $ (newAndOldAttrs, \tup -> case evalAtomExpr tup context atomExpr of
499− Left _ -> error "logic failure in extendTupleExpressionProcessor"
500− Right atom -> tupleAtomExtend newAttrName atom tup)
501−
502−evalAtomExpr :: RelationTuple -> DatabaseContext -> AtomExpr -> Either RelationalError Atom
503−evalAtomExpr tupIn _ (AttributeAtomExpr attrName) = atomForAttributeName attrName tupIn
504−evalAtomExpr _ _ (NakedAtomExpr atom) = Right atom
505−evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments ()) = do
506− let functions = atomFunctions context
507− func <- atomFunctionForName funcName functions
508− argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn) context) arguments
509− let expectedArgCount = length (atomFuncType func) - 1
510− actualArgCount = length argTypes
511− safeInit [_] = []
512− safeInit [] = [] -- different behavior from normal init
513− safeInit (_:xs) = safeInit xs
514− if expectedArgCount /= actualArgCount then
515− Left (AtomFunctionArgumentCountMismatch expectedArgCount actualArgCount)
516− else do
517− _ <- mapM (uncurry atomTypeVerify) $ safeInit (zip (atomFuncType func) argTypes)
518− evaldArgs <- mapM (evalAtomExpr tupIn context) arguments
519− pure $ (evalAtomFunction func) evaldArgs
520−evalAtomExpr _ context (RelationAtomExpr relExpr) = do
521− relAtom <- evalState (evalRelationalExpr relExpr) context
522− return $ RelationAtom relAtom
523−evalAtomExpr tupIn context cons@(ConstructedAtomExpr dConsName dConsArgs ()) = do
524− aType <- typeFromAtomExpr (tupleAttributes tupIn) context cons
525− argAtoms <- mapM (evalAtomExpr tupIn context) dConsArgs
527+extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
528+extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
529+ state <- get
530+ -- check that the attribute name is not in use
531+ case tupleExprCheckNewAttrName newAttrName relIn of
532+ Left err -> pure (Left err)
533+ Right _ -> runExceptT $ do
534+ atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)
535+ _ <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
536+ let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]
537+ newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
538+ pure $ (newAndOldAttrs, \tup -> case evalState (evalAtomExpr tup atomExpr) state of
539+ Left err -> Left err
540+ Right atom -> Right (tupleAtomExtend newAttrName atom tup))
541+
542+evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
543+evalAtomExpr tupIn (AttributeAtomExpr attrName) = pure (atomForAttributeName attrName tupIn)
544+evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)
545+evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
546+ argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments
547+ context <- liftM stateContext get
548+ runExceptT $ do
549+ let functions = atomFunctions context
550+ func <- either throwE pure (atomFunctionForName funcName functions)
551+ let expectedArgCount = length (atomFuncType func) - 1
552+ actualArgCount = length argTypes
553+ safeInit [_] = []
554+ safeInit [] = [] -- different behavior from normal init
555+ safeInit (_:xs) = safeInit xs
556+ if expectedArgCount /= actualArgCount then
557+ throwE (AtomFunctionArgumentCountMismatch expectedArgCount actualArgCount)
558+ else do
559+ _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))
560+ evaldArgs <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) arguments
561+ pure $ (evalAtomFunction func) evaldArgs
562+evalAtomExpr tupIn (RelationAtomExpr relExpr) = do
563+ --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
564+ runExceptT $ do
565+ relAtom <- liftE (evalRelationalExpr relExpr)
566+ pure (RelationAtom relAtom)
567+evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
568+ aType <- liftE (typeFromAtomExpr (tupleAttributes tupIn) cons)
569+ argAtoms <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) dConsArgs
526570 pure (ConstructedAtom dConsName aType argAtoms)
527571
528−typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType
529−typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs
530−typeFromAtomExpr _ _ (NakedAtomExpr atom) = Right (atomTypeForAtom atom)
531−typeFromAtomExpr _ context (FunctionAtomExpr funcName _ _) = do
572+typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
573+typeFromAtomExpr attrs (AttributeAtomExpr attrName) = pure (A.atomTypeForAttributeName attrName attrs)
574+typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
575+typeFromAtomExpr _ (FunctionAtomExpr funcName _ _) = do
576+ context <- liftM stateContext get
532577 let funcs = atomFunctions context
533− func <- atomFunctionForName funcName funcs
534− return $ last (atomFuncType func)
535−typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do
536− relType <- evalState (typeForRelationalExpr relExpr) context
537− return $ RelationAtomType (attributes relType)
538−
578+ runExceptT $ do
579+ func <- either throwE pure (atomFunctionForName funcName funcs)
580+ pure (last (atomFuncType func))
581+typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
582+ relType <- liftE (typeForRelationalExpr relExpr)
583+ pure (RelationAtomType (attributes relType))
539584-- grab the type of the data constructor, then validate that the args match the expected types
540−typeFromAtomExpr attrs context (ConstructedAtomExpr dConsName dConsArgs _) = do
541− argsTypes <- mapM (typeFromAtomExpr attrs context) dConsArgs
542− atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes
585+typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
586+ runExceptT $ do
587+ argsTypes <- mapM (\arg -> liftE (typeFromAtomExpr attrs arg)) dConsArgs
588+ context <- liftM stateContext get
589+ aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)
590+ pure aType
543591
544592-- | Validate that the type of the AtomExpr matches the expected type.
545−verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType
546−verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do
547− attrType <- A.atomTypeForAttributeName attrName (attributes relIn)
548− atomTypeVerify expectedType attrType
549−verifyAtomExprTypes _ _ (NakedAtomExpr atom) expectedType = atomTypeVerify expectedType (atomTypeForAtom atom)
550−verifyAtomExprTypes relIn context (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
593+verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
594+verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
595+ attrType <- either throwE pure (A.atomTypeForAttributeName attrName (attributes relIn))
596+ either throwE pure (atomTypeVerify expectedType attrType)
597+verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
598+verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
599+ state <- get
551600 let functions = atomFunctions context
552− func <- atomFunctionForName funcName functions
553− let expectedArgTypes = atomFuncType func
554− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case verifyAtomExprTypes relIn context atomExpr expectedType2 of
555− Left (AtomTypeMismatchError expSubType actSubType) -> Left $ AtomFunctionTypeError funcName argCount expSubType actSubType
556− Left err -> Left err
557− Right x -> Right x
601+ context = stateContext state
602+ runExceptT $ do
603+ func <- either throwE pure (atomFunctionForName funcName functions)
604+ let expectedArgTypes = atomFuncType func
605+ funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case evalState (verifyAtomExprTypes relIn atomExpr expectedType2) state of
606+ Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
607+ Left err -> throwE (err)
608+ Right x -> pure x
558609 ) $ zip3 funcArgExprs expectedArgTypes [1..]
559− if length funcArgTypes /= length expectedArgTypes - 1 then
560− Left $ AtomTypeCountError funcArgTypes expectedArgTypes
561− else do
562− atomTypeVerify expectedType (last expectedArgTypes)
563−verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do
564− case runState (typeForRelationalExpr relationExpr) context of
565− (Left err, _) -> Left err
566− (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))
567−verifyAtomExprTypes rel context cons@(ConstructedAtomExpr _ _ _) expectedType = do
568− cType <- typeFromAtomExpr (attributes rel) context cons
569− atomTypeVerify expectedType cType
570−
610+ if length funcArgTypes /= length expectedArgTypes - 1 then
611+ throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
612+ else do
613+ either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
614+verifyAtomExprTypes _ (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
615+ relType <- liftE (typeForRelationalExpr relationExpr)
616+ either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
617+verifyAtomExprTypes rel cons@(ConstructedAtomExpr _ _ _) expectedType = runExceptT $ do
618+ cType <- liftE (typeFromAtomExpr (attributes rel) cons)
619+ either throwE pure (atomTypeVerify expectedType cType)
571620
572621-- | Look up the type's name and create a new attribute.
573622evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute
@@ -577,23 +626,24 @@ evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do
577626
578627evalAttrExpr _ (NakedAttributeExpr attr) = Right attr
579628
580−evalTupleExpr :: DatabaseContext -> Maybe Attributes -> TupleExpr -> Either RelationalError RelationTuple
581−evalTupleExpr context attrs (TupleExpr tupMap) = do
629+evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)
630+evalTupleExpr attrs (TupleExpr tupMap) = runExceptT $ do
582631 -- 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
583632 -- 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
633+ context <- liftM stateContext get
584634 attrAtoms <- mapM (\(attrName, aExpr) -> do
585− newAtom <- evalAtomExpr emptyTuple context aExpr
586− newAtomType <- typeFromAtomExpr A.emptyAttributes context aExpr
587− pure $ (attrName, newAtom, newAtomType)
588− ) (M.toList tupMap)
635+ newAtom <- liftE (evalAtomExpr emptyTuple aExpr)
636+ newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)
637+ pure (attrName, newAtom, newAtomType)
638+ ) (M.toList tupMap)
589639 let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms
590640 atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms
591641 tup = mkRelationTuple tupAttrs atoms
592642 tConss = typeConstructorMapping context
593643 finalAttrs = fromMaybe tupAttrs attrs
594644 --verify that the attributes match
595− when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ Left (TupleAttributeTypeMismatchError tupAttrs)
596− tup' <- resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup)
597− _ <- validateTuple tup' tConss
645+ when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)
646+ tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))
647+ _ <- either throwE pure (validateTuple tup' tConss)
598648 pure tup'
599649