@@ -24,25 +24,45 @@ import Control.Monad.Trans.Except
2424
2525import GHC
2626import GHC.Paths
27−--import Debug.Trace
27+import Debug.Trace
2828
2929-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52
3030data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr
3131 RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr
3232 RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation
33+
34+instance Show RelationalExprStateElems where
35+ show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup
36+ show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs
37+ show (RelationalExprStateElems _) = "RelationalExprStateElems"
38+
39+mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems
40+mkRelationalExprState ctx = RelationalExprStateElems ctx
41+
42+mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems
43+mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn
44+mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st
45+mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in
46+ RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)
47+
48+mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems
49+mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs
50+mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st
51+mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)
52+
3353type DatabaseState a = State DatabaseContext a
3454
3555type RelationalExprState a = State RelationalExprStateElems a
3656
3757stateContext :: RelationalExprStateElems -> DatabaseContext
3858stateContext (RelationalExprStateTupleElems ctx _) = ctx
39−stateContext (RelationalExprStateAttrsElems ctx _) = ctx
4059stateContext (RelationalExprStateElems ctx) = ctx
60+stateContext (RelationalExprStateAttrsElems ctx _) = ctx
4161
4262setStateContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems
4363setStateContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup
44−setStateContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
4564setStateContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx
65+setStateContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs
4666
4767--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
4868evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
@@ -95,10 +115,11 @@ evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
95115 let tConss = typeConstructorMapping currentContext
96116 -- 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
97117 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)
118+ mAttrs <- case mAttrExprs of
119+ Just _ -> do
120+ attrs <- mapM (\expr -> either throwE pure (evalAttrExpr tConss expr)) (fromMaybe [] mAttrExprs)
121+ pure (Just (A.attributesFromList attrs))
122+ Nothing -> pure Nothing
102123 tuples <- mapM (\expr -> liftE (evalTupleExpr mAttrs expr)) tupleExprs
103124 let attrs = fromMaybe firstTupleAttrs mAttrs
104125 firstTupleAttrs = if length tuples == 0 then A.emptyAttributes else tupleAttributes (head tuples)
@@ -155,15 +176,15 @@ evalRelationalExpr (NotEquals relExprA relExprB) = do
155176
156177-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated
157178evalRelationalExpr (Extend tupleExpression relExpr) = do
158− state <- get
159− let evald = evalState (evalRelationalExpr relExpr) state
179+ rstate <- get
180+ let evald = evalState (evalRelationalExpr relExpr) rstate
160181 case evald of
161− Left err -> return $ Left err
182+ Left err -> pure (Left err)
162183 Right rel -> do
163184 tupProc <- extendTupleExpressionProcessor rel tupleExpression
164185 case tupProc of
165186 Left err -> pure (Left err)
166− Right (newAttrs, tupProc) -> pure $ relMogrify tupProc newAttrs rel
187+ Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel
167188
168189emptyDatabaseContext :: DatabaseContext
169190emptyDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,
@@ -438,12 +459,12 @@ checkConstraint (InclusionDependency name subDep superDep) = do
438459
439460typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)
440461typeForRelationalExpr expr = do
441− state <- get
442− let context = stateContext state
462+ rstate <- get
463+ let context = stateContext rstate
443464 --replace the relationVariables context element with a cloned set of relation devoid of tuples
444465 let context' = contextWithEmptyTupleSets context
445− state' = setStateContext state context'
446− pure (evalState (evalRelationalExpr expr) state')
466+ rstate' = setStateContext rstate context'
467+ pure (evalState (evalRelationalExpr expr) rstate')
447468
448469--returns a database context with all tuples removed
449470--this is useful for type checking and optimization
@@ -480,7 +501,8 @@ predicateRestrictionFilter attrs (NotPredicate expr) = do
480501 exprv <- liftE (predicateRestrictionFilter attrs expr)
481502 pure (\x -> not (exprv x))
482503
483−predicateRestrictionFilter attrs (RelationalExprPredicate relExpr) = runExceptT $ do
504+predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = runExceptT $ do
505+ --merge attrs into to state attributes
484506 rel <- liftE (evalRelationalExpr relExpr)
485507 if rel == relationTrue then
486508 pure (\_ -> True)
@@ -490,7 +512,8 @@ predicateRestrictionFilter attrs (RelationalExprPredicate relExpr) = runExceptT
490512 throwE (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")
491513
492514predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do
493− state <- get
515+ --merge attrs into the state attributes
516+ rstate <- get
494517 runExceptT $ do
495518 atomExprType <- liftE (typeFromAtomExpr attrs atomExpr)
496519 attr <- either throwE pure (A.attributeForName attrName attrs)
@@ -500,21 +523,22 @@ predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr)
500523 pure $ \tupleIn -> case atomForAttributeName attrName tupleIn of
501524 Left _ -> False
502525 Right atomIn ->
503− let atomEvald = evalState (evalAtomExpr tupleIn atomExpr) state in
526+ let atomEvald = evalState (evalAtomExpr tupleIn atomExpr) rstate in
504527 case atomEvald of
505528 Left _ -> False
506529 Right atomCmp -> atomCmp == atomIn
507530
508531-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance
509532predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do
510− state <- get
533+ --merge attrs into the state attributes
534+ rstate <- get
511535 runExceptT $ do
512536 aType <- liftE (typeFromAtomExpr attrs atomExpr)
513537 if aType /= BoolAtomType then
514538 throwE (AtomTypeMismatchError aType BoolAtomType)
515539 else
516540 pure (\tupleIn -> do
517− case evalState (evalAtomExpr tupleIn atomExpr) state of
541+ case evalState (evalAtomExpr tupleIn atomExpr) rstate of
518542 Left _ -> False
519543 Right boolAtomValue -> boolAtomValue == BoolAtom True)
520544
@@ -526,7 +550,7 @@ tupleExprCheckNewAttrName attrName rel = if isRight $ attributeForName attrName
526550
527551extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))
528552extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do
529− state <- get
553+ rstate <- get
530554 -- check that the attribute name is not in use
531555 case tupleExprCheckNewAttrName newAttrName relIn of
532556 Left err -> pure (Left err)
@@ -535,9 +559,10 @@ extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomE
535559 _ <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)
536560 let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType]
537561 newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs
538− pure $ (newAndOldAttrs, \tup -> case evalState (evalAtomExpr tup atomExpr) state of
562+ pure $ (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case evalState (evalAtomExpr tup atomExpr) substate of
539563 Left err -> Left err
540− Right atom -> Right (tupleAtomExtend newAttrName atom tup))
564+ Right atom -> Right (tupleAtomExtend newAttrName atom tup)
565+ )
541566
542567evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)
543568evalAtomExpr tupIn (AttributeAtomExpr attrName) = pure (atomForAttributeName attrName tupIn)
@@ -561,16 +586,34 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
561586 pure $ (evalAtomFunction func) evaldArgs
562587evalAtomExpr tupIn (RelationAtomExpr relExpr) = do
563588 --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes
589+ rstate <- get
564590 runExceptT $ do
565− relAtom <- liftE (evalRelationalExpr relExpr)
591+ let newState = mergeTuplesIntoRelationalExprState tupIn rstate
592+ traceShowM newState
593+ relAtom <- either throwE pure (evalState (evalRelationalExpr relExpr) newState)
566594 pure (RelationAtom relAtom)
567595evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do
568− aType <- liftE (typeFromAtomExpr (tupleAttributes tupIn) cons)
569− argAtoms <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) dConsArgs
596+ rstate <- get
597+ let newState = mergeTuplesIntoRelationalExprState tupIn rstate
598+ aType <- either throwE pure (evalState (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)
599+ argAtoms <- mapM (\arg -> either throwE pure (evalState (evalAtomExpr tupIn arg) newState)) dConsArgs
570600 pure (ConstructedAtom dConsName aType argAtoms)
571601
572602typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)
573−typeFromAtomExpr attrs (AttributeAtomExpr attrName) = pure (A.atomTypeForAttributeName attrName attrs)
603+typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do
604+ --first, check if the attribute is in the immediate attributes
605+ rstate <- get
606+ case A.atomTypeForAttributeName attrName attrs of
607+ Right aType -> pure (Right aType)
608+ Left err@(NoSuchAttributeNamesError _) -> case rstate of
609+ RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of
610+ Left err' -> pure (Left err')
611+ Right attr -> pure (Right (A.atomType attr))
612+ RelationalExprStateElems _ -> pure (Left err)
613+ RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of
614+ Left err' -> pure (Left err')
615+ Right atom -> pure (Right (atomTypeForAtom atom))
616+ Left err -> pure (Left err)
574617typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))
575618typeFromAtomExpr _ (FunctionAtomExpr funcName _ _) = do
576619 context <- liftM stateContext get
@@ -579,7 +622,8 @@ typeFromAtomExpr _ (FunctionAtomExpr funcName _ _) = do
579622 func <- either throwE pure (atomFunctionForName funcName funcs)
580623 pure (last (atomFuncType func))
581624typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do
582− relType <- liftE (typeForRelationalExpr relExpr)
625+ rstate <- get
626+ relType <- either throwE pure (evalState (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))
583627 pure (RelationAtomType (attributes relType))
584628-- grab the type of the data constructor, then validate that the args match the expected types
585629typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
@@ -592,17 +636,25 @@ typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) =
592636-- | Validate that the type of the AtomExpr matches the expected type.
593637verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)
594638verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do
595− attrType <- either throwE pure (A.atomTypeForAttributeName attrName (attributes relIn))
596− either throwE pure (atomTypeVerify expectedType attrType)
639+ rstate <- get
640+ case A.atomTypeForAttributeName attrName (attributes relIn) of
641+ Right aType -> pure aType
642+ Left (NoSuchAttributeNamesError _) -> case rstate of
643+ RelationalExprStateTupleElems _ _ -> error "impossible"
644+ RelationalExprStateElems _ -> error "poop"
645+ RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of
646+ Left err' -> throwE err'
647+ Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))
648+ Left err -> throwE err
597649verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))
598650verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do
599− state <- get
651+ rstate <- get
600652 let functions = atomFunctions context
601− context = stateContext state
653+ context = stateContext rstate
602654 runExceptT $ do
603655 func <- either throwE pure (atomFunctionForName funcName functions)
604656 let expectedArgTypes = atomFuncType func
605− funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case evalState (verifyAtomExprTypes relIn atomExpr expectedType2) state of
657+ funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case evalState (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of
606658 Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)
607659 Left err -> throwE (err)
608660 Right x -> pure x
@@ -611,8 +663,9 @@ verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedTyp
611663 throwE (AtomTypeCountError funcArgTypes expectedArgTypes)
612664 else do
613665 either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))
614−verifyAtomExprTypes _ (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
615− relType <- liftE (typeForRelationalExpr relationExpr)
666+verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do
667+ rstate <- get
668+ relType <- either throwE pure (evalState (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))
616669 either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))
617670verifyAtomExprTypes rel cons@(ConstructedAtomExpr _ _ _) expectedType = runExceptT $ do
618671 cType <- liftE (typeFromAtomExpr (attributes rel) cons)