git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/lib/ProjectM36/TransGraphRelationalExpression.hs
197 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.Error
8import qualified Data.Map as M
9import Control.Monad.Trans.Reader
10import Control.Monad.Trans.Class
11import Control.Monad.Trans.Except
12import Data.Functor.Identity
13import Data.Binary
15-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).
16type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup
18instance Binary TransGraphRelationalExpr
20type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup
22instance Binary TransGraphAttributeNames
24type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup
26instance Binary TransGraphExtendTupleExpr
28type TransGraphTupleExpr = TupleExprBase TransactionIdLookup
30instance Binary TransGraphTupleExpr
32type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup
34instance Binary TransGraphTupleExprs
36type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup
38instance Binary TransGraphRestrictionPredicateExpr
40type TransGraphAtomExpr = AtomExprBase TransactionIdLookup
42instance Binary TransGraphAtomExpr
44type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup
46type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup
48instance Binary TransGraphWithNameExpr
50newtype TransGraphEvalEnv = TransGraphEvalEnv {
51 tge_graph :: TransactionGraph
52 }
54type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a
56process :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr
57process env texpr = runIdentity (runExceptT (runReaderT (processTransGraphRelationalExpr texpr) env))
59liftE :: Either RelationalError a -> TransGraphEvalMonad a
60liftE = lift . except
62askGraph :: TransGraphEvalMonad TransactionGraph
63askGraph = tge_graph <$> ask
65findTransId :: TransactionIdLookup -> TransGraphEvalMonad GraphRefTransactionMarker
66findTransId tlook = TransactionMarker . transactionId <$> findTrans tlook
68findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction
69findTrans tlook = do
70 graph <- askGraph
71 liftE $ lookupTransaction graph tlook
73-- 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.
74processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr
75processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
76 tupleExprs' <- processTransGraphTupleExprs tupleExprs
77 case mAttrExprs of
78 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')
79 Just attrExprs -> do
80 attrExprs' <- mapM processTransGraphAttributeExpr attrExprs
81 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')
82processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
83processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
84processTransGraphRelationalExpr (RelationVariable rvname transLookup) =
85 RelationVariable rvname <$> findTransId transLookup
86processTransGraphRelationalExpr (Project transAttrNames expr) =
87 Project <$> processTransGraphAttributeNames transAttrNames <*> processTransGraphRelationalExpr expr
88processTransGraphRelationalExpr (Union exprA exprB) =
89 Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
90processTransGraphRelationalExpr (Join exprA exprB) =
91 Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
92processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =
93 Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr
94processTransGraphRelationalExpr (Difference exprA exprB) =
95 Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
96processTransGraphRelationalExpr (Group transAttrNames attrName expr) =
97 Group <$>
98 processTransGraphAttributeNames transAttrNames <*>
99 pure attrName <*>
100 processTransGraphRelationalExpr expr
101processTransGraphRelationalExpr (Ungroup attrName expr) =
102 Ungroup attrName <$> processTransGraphRelationalExpr expr
103processTransGraphRelationalExpr (Restrict predicateExpr expr) =
104 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>
105 processTransGraphRelationalExpr expr
106processTransGraphRelationalExpr (Equals exprA exprB) = do
107 exprA' <- processTransGraphRelationalExpr exprA
108 exprB' <- processTransGraphRelationalExpr exprB
109 pure (Equals exprA' exprB')
110processTransGraphRelationalExpr (NotEquals exprA exprB) = do
111 exprA' <- processTransGraphRelationalExpr exprA
112 exprB' <- processTransGraphRelationalExpr exprB
113 pure (NotEquals exprA' exprB')
114processTransGraphRelationalExpr (Extend extendExpr expr) = do
115 extendExpr' <- processTransGraphExtendTupleExpr extendExpr
116 expr' <- processTransGraphRelationalExpr expr
117 pure (Extend extendExpr' expr')
118processTransGraphRelationalExpr (With views expr) = do
119 evaldViews <- mapM (\(wnexpr, vexpr) -> do
120 wnexpr' <- processTransGraphWithNameExpr wnexpr
121 vexpr' <- processTransGraphRelationalExpr vexpr
122 pure (wnexpr', vexpr')
123 ) views
124 expr' <- processTransGraphRelationalExpr expr
125 pure (With evaldViews expr')
127processTransGraphTupleExprs :: TransGraphTupleExprs -> TransGraphEvalMonad GraphRefTupleExprs
128processTransGraphTupleExprs (TupleExprs marker texprs) =
129 TupleExprs <$> findTransId marker <*> mapM processTransGraphTupleExpr texprs
131processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr
132processTransGraphTupleExpr (TupleExpr attrMap) = do
133 let attrAssoc = mapM (\(attrName, atomExpr) -> do
134 aExpr <- processTransGraphAtomExpr atomExpr
135 pure (attrName, aExpr)
136 ) (M.toList attrMap)
137 TupleExpr . M.fromList <$> attrAssoc
139processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr
140processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname
141processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
142processTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =
143 FunctionAtomExpr funcName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
144processTransGraphAtomExpr (RelationAtomExpr expr) =
145 RelationAtomExpr <$> processTransGraphRelationalExpr expr
146processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =
147 ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
148evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr
149evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate
150evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do
151 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
152 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
153 pure (AndPredicate exprA' exprB')
154evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) = do
155 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
156 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
157 pure (OrPredicate exprA' exprB')
158evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do
159 let expr' = evalTransGraphRestrictionPredicateExpr expr
160 NotPredicate <$> expr'
161evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do
162 let expr' = processTransGraphRelationalExpr expr
163 RelationalExprPredicate <$> expr'
164evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do
165 let expr' = processTransGraphAtomExpr expr
166 AtomExprPredicate <$> expr'
167evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do
168 let expr' = processTransGraphAtomExpr expr
169 AttributeEqualityPredicate attrName <$> expr'
171processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr
172processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) =
173 AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr
175processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr
176processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =
177 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup
178processTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)
180processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames
181processTransGraphAttributeNames (AttributeNames names) = pure (AttributeNames names)
182processTransGraphAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)
183processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do
184 nA <- processTransGraphAttributeNames namesA
185 nB <- processTransGraphAttributeNames namesB
186 pure (UnionAttributeNames nA nB)
187processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do
188 nA <- processTransGraphAttributeNames namesA
189 nB <- processTransGraphAttributeNames namesB
190 pure (IntersectAttributeNames nA nB)
191processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do
192 evaldExpr <- processTransGraphRelationalExpr expr
193 pure (RelationalExprAttributeNames evaldExpr)
195processTransGraphWithNameExpr :: TransGraphWithNameExpr -> TransGraphEvalMonad GraphRefWithNameExpr
196processTransGraphWithNameExpr (WithNameExpr rvname tlookup) =
197 WithNameExpr rvname <$> findTransId tlookup