git.iko.soy/project-m36
on fc8cecc help sign in
project-m36/src/lib/ProjectM36/TransGraphRelationalExpression.hs
182 lines 10 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3--really, a better name for this module could be "TransTransactionGraphRelationalExpr", but that name is too long
4module ProjectM36.TransGraphRelationalExpression where
5import ProjectM36.Base
6import ProjectM36.TransactionGraph
7import ProjectM36.Transaction
8import ProjectM36.RelationalExpression
9import ProjectM36.Error
10import ProjectM36.Tuple
11import ProjectM36.AtomType
12import qualified Data.Map as M
13import Control.Monad.Trans.Reader
14import Data.Binary
16-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).
17type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup
19instance Binary TransGraphRelationalExpr
21type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup
23instance Binary TransGraphAttributeNames
25type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup
27instance Binary TransGraphExtendTupleExpr
29type TransGraphTupleExpr = TupleExprBase TransactionIdLookup
31instance Binary TransGraphTupleExpr
33type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup
35instance Binary TransGraphRestrictionPredicateExpr
37type TransGraphAtomExpr = AtomExprBase TransactionIdLookup
39instance Binary TransGraphAtomExpr
41type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup
43-- OUTDATED a previous attempt at this function attempted to convert TransGraphRelationalExpr to RelationalExpr by resolving the transaction lookups. However, there is no way to resolve a FunctionAtomExpr to an Atom without fully evaluating the higher levels (TupleExpr, etc.). An anonymous function expression cannot be serialized, so that workaround is out. Still, I suspect we can reuse the existing static optimizer logic to work on both structures. The current conversion reduces the chance of whole-query optimization due to full-evaluation on top of full-evaluation, so this function would benefit from some re-design.
44evalTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransactionGraph -> Either RelationalError RelationalExpr
45evalTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) graph = do
46 tupleExprs' <- mapM (evalTransGraphTupleExpr graph) tupleExprs
47 case mAttrExprs of
48 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')
49 Just attrExprs -> do
50 attrExprs' <- mapM (evalTransGraphAttributeExpr graph) attrExprs
51 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')
52evalTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) _ = pure (MakeStaticRelation attrs tupSet)
53evalTransGraphRelationalExpr (ExistingRelation rel) _ = pure (ExistingRelation rel)
54evalTransGraphRelationalExpr (RelationVariable rvname transLookup) graph = do
55 trans <- lookupTransaction graph transLookup
56 rel <- runReader (evalRelationalExpr (RelationVariable rvname ())) (RelationalExprStateElems (concreteDatabaseContext trans))
57 pure (ExistingRelation rel)
58evalTransGraphRelationalExpr (Project transAttrNames expr) graph = do
59 expr' <- evalTransGraphRelationalExpr expr graph
60 attrNames <- evalTransAttributeNames transAttrNames graph
61 pure (Project attrNames expr')
62evalTransGraphRelationalExpr (Union exprA exprB) graph = do
63 exprA' <- evalTransGraphRelationalExpr exprA graph
64 exprB' <- evalTransGraphRelationalExpr exprB graph
65 pure (Union exprA' exprB')
66evalTransGraphRelationalExpr (Join exprA exprB) graph = do
67 exprA' <- evalTransGraphRelationalExpr exprA graph
68 exprB' <- evalTransGraphRelationalExpr exprB graph
69 pure (Join exprA' exprB')
70evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) graph = do
71 let expr' = evalTransGraphRelationalExpr expr graph
72 Rename attrName1 attrName2 <$> expr'
73evalTransGraphRelationalExpr (Difference exprA exprB) graph = do
74 exprA' <- evalTransGraphRelationalExpr exprA graph
75 exprB' <- evalTransGraphRelationalExpr exprB graph
76 pure (Difference exprA' exprB')
77evalTransGraphRelationalExpr (Group transAttrNames attrName expr) graph = do
78 expr' <- evalTransGraphRelationalExpr expr graph
79 attrNames <- evalTransAttributeNames transAttrNames graph
80 pure (Group attrNames attrName expr')
81evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do
82 let expr' = evalTransGraphRelationalExpr expr graph
83 Ungroup attrName <$> expr'
84evalTransGraphRelationalExpr (Restrict predicateExpr expr) graph = do
85 expr' <- evalTransGraphRelationalExpr expr graph
86 predicateExpr' <- evalTransGraphRestrictionPredicateExpr predicateExpr graph
87 pure (Restrict predicateExpr' expr')
88evalTransGraphRelationalExpr (Equals exprA exprB) graph = do
89 exprA' <- evalTransGraphRelationalExpr exprA graph
90 exprB' <- evalTransGraphRelationalExpr exprB graph
91 pure (Equals exprA' exprB')
92evalTransGraphRelationalExpr (NotEquals exprA exprB) graph = do
93 exprA' <- evalTransGraphRelationalExpr exprA graph
94 exprB' <- evalTransGraphRelationalExpr exprB graph
95 pure (NotEquals exprA' exprB')
96evalTransGraphRelationalExpr (Extend extendExpr expr) graph = do
97 extendExpr' <- evalTransGraphExtendTupleExpr extendExpr graph
98 expr' <- evalTransGraphRelationalExpr expr graph
99 pure (Extend extendExpr' expr')
100evalTransGraphRelationalExpr (With views expr) graph = do
101 evaldViews <- mapM (\(vname, vexpr) -> do
102 vexpr' <- evalTransGraphRelationalExpr vexpr graph
103 pure (vname, vexpr')
104 ) views
105 expr' <- evalTransGraphRelationalExpr expr graph
106 pure (With evaldViews expr')
108evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr
109evalTransGraphTupleExpr graph (TupleExpr attrMap) = do
110 let attrAssoc = mapM (\(attrName, atomExpr) -> do
111 aExpr <- evalTransGraphAtomExpr graph atomExpr
112 pure (attrName, aExpr)
113 ) (M.toList attrMap)
114 TupleExpr . M.fromList <$> attrAssoc
116evalTransGraphAtomExpr :: TransactionGraph -> TransGraphAtomExpr -> Either RelationalError AtomExpr
117evalTransGraphAtomExpr _ (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname
118evalTransGraphAtomExpr _ (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
119evalTransGraphAtomExpr graph (FunctionAtomExpr funcName args tLookup) = do
120 trans <- lookupTransaction graph tLookup
121 --I can't return a FunctionAtomExpr because the function needs to be resolved at a specific context
122 args' <- mapM (evalTransGraphAtomExpr graph) args
123 atom <- runReader (evalAtomExpr emptyTuple (FunctionAtomExpr funcName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))
124 pure (NakedAtomExpr atom)
125evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do
126 let expr' = evalTransGraphRelationalExpr expr graph
127 RelationAtomExpr <$> expr'
128evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do
129 trans <- lookupTransaction graph tLookup
130 args' <- mapM (evalTransGraphAtomExpr graph) args
131 atom <- runReader (evalAtomExpr emptyTuple (ConstructedAtomExpr dConsName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))
132 pure (NakedAtomExpr atom)
134evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransactionGraph -> Either RelationalError RestrictionPredicateExpr
135evalTransGraphRestrictionPredicateExpr TruePredicate _ = pure TruePredicate
136evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) graph = do
137 exprA' <- evalTransGraphRestrictionPredicateExpr exprA graph
138 exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph
139 pure (AndPredicate exprA' exprB')
140evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) graph = do
141 exprA' <- evalTransGraphRestrictionPredicateExpr exprA graph
142 exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph
143 pure (OrPredicate exprA' exprB')
144evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do
145 let expr' = evalTransGraphRestrictionPredicateExpr expr graph
146 NotPredicate <$> expr'
147evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do
148 let expr' = evalTransGraphRelationalExpr expr graph
149 RelationalExprPredicate <$> expr'
150evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do
151 let expr' = evalTransGraphAtomExpr graph expr
152 AtomExprPredicate <$> expr'
153evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do
154 let expr' = evalTransGraphAtomExpr graph expr
155 AttributeEqualityPredicate attrName <$> expr'
157evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr
158evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do
159 let expr' = evalTransGraphAtomExpr graph expr
160 AttributeExtendTupleExpr attrName <$> expr'
162evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr
163evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do
164 trans <- lookupTransaction graph tLookup
165 aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans)) M.empty
166 pure (NakedAttributeExpr (Attribute attrName aType))
167evalTransGraphAttributeExpr _ (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)
169evalTransAttributeNames :: TransGraphAttributeNames -> TransactionGraph -> Either RelationalError AttributeNames
170evalTransAttributeNames (AttributeNames names) _ = Right (AttributeNames names)
171evalTransAttributeNames (InvertedAttributeNames names) _ = Right (InvertedAttributeNames names)
172evalTransAttributeNames (UnionAttributeNames namesA namesB) graph = do
173 nA <- evalTransAttributeNames namesA graph
174 nB <- evalTransAttributeNames namesB graph
175 Right (UnionAttributeNames nA nB)
176evalTransAttributeNames (IntersectAttributeNames namesA namesB) graph = do
177 nA <- evalTransAttributeNames namesA graph
178 nB <- evalTransAttributeNames namesB graph
179 Right (IntersectAttributeNames nA nB)
180evalTransAttributeNames (RelationalExprAttributeNames expr) graph = do
181 evaldExpr <- evalTransGraphRelationalExpr expr graph
182 Right (RelationalExprAttributeNames evaldExpr)