git.iko.soy/project-m36
on 1706097 help sign in
project-m36/src/lib/ProjectM36/TransGraphRelationalExpression.hs
180 lines 9.7 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 TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup
34instance Binary TransGraphRestrictionPredicateExpr
36type TransGraphAtomExpr = AtomExprBase TransactionIdLookup
38instance Binary TransGraphAtomExpr
40type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup
42data TransGraphEvalEnv = TransGraphEvalEnv {
43 tge_graph :: TransactionGraph
44 }
46type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a
48process :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr
49process env texpr = runIdentity (runExceptT (runReaderT (processTransGraphRelationalExpr texpr) env))
51liftE :: Either RelationalError a -> TransGraphEvalMonad a
52liftE = lift . except
54askGraph :: TransGraphEvalMonad TransactionGraph
55askGraph = tge_graph <$> ask
57findTransId :: TransactionIdLookup -> TransGraphEvalMonad TransactionId
58findTransId tlook = transactionId <$> findTrans tlook
60findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction
61findTrans tlook = do
62 graph <- askGraph
63 liftE $ lookupTransaction graph tlook
65-- 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.
66processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr
67processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
68 tupleExprs' <- mapM processTransGraphTupleExpr tupleExprs
69 case mAttrExprs of
70 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')
71 Just attrExprs -> do
72 attrExprs' <- mapM processTransGraphAttributeExpr attrExprs
73 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')
74processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
75processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
76processTransGraphRelationalExpr (RelationVariable rvname transLookup) =
77 RelationVariable rvname <$> findTransId transLookup
78processTransGraphRelationalExpr (Project transAttrNames expr) =
79 Project <$> processTransGraphAttributeNames transAttrNames <*> processTransGraphRelationalExpr expr
80processTransGraphRelationalExpr (Union exprA exprB) =
81 Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
82processTransGraphRelationalExpr (Join exprA exprB) =
83 Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
84processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =
85 Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr
86processTransGraphRelationalExpr (Difference exprA exprB) =
87 Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
88processTransGraphRelationalExpr (Group transAttrNames attrName expr) =
89 Group <$>
90 processTransGraphAttributeNames transAttrNames <*>
91 pure attrName <*>
92 processTransGraphRelationalExpr expr
93processTransGraphRelationalExpr (Ungroup attrName expr) =
94 Ungroup attrName <$> processTransGraphRelationalExpr expr
95processTransGraphRelationalExpr (Restrict predicateExpr expr) =
96 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>
97 processTransGraphRelationalExpr expr
98processTransGraphRelationalExpr (Equals exprA exprB) = do
99 exprA' <- processTransGraphRelationalExpr exprA
100 exprB' <- processTransGraphRelationalExpr exprB
101 pure (Equals exprA' exprB')
102processTransGraphRelationalExpr (NotEquals exprA exprB) = do
103 exprA' <- processTransGraphRelationalExpr exprA
104 exprB' <- processTransGraphRelationalExpr exprB
105 pure (NotEquals exprA' exprB')
106processTransGraphRelationalExpr (Extend extendExpr expr) = do
107 extendExpr' <- processTransGraphExtendTupleExpr extendExpr
108 expr' <- processTransGraphRelationalExpr expr
109 pure (Extend extendExpr' expr')
110processTransGraphRelationalExpr (With views expr) = do
111 evaldViews <- mapM (\(vname, vexpr) -> do
112 vexpr' <- processTransGraphRelationalExpr vexpr
113 pure (vname, vexpr')
114 ) views
115 expr' <- processTransGraphRelationalExpr expr
116 pure (With evaldViews expr')
118processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr
119processTransGraphTupleExpr (TupleExpr attrMap) = do
120 let attrAssoc = mapM (\(attrName, atomExpr) -> do
121 aExpr <- processTransGraphAtomExpr atomExpr
122 pure (attrName, aExpr)
123 ) (M.toList attrMap)
124 TupleExpr . M.fromList <$> attrAssoc
126processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr
127processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname
128processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
129processTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =
130 FunctionAtomExpr funcName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
131processTransGraphAtomExpr (RelationAtomExpr expr) =
132 RelationAtomExpr <$> processTransGraphRelationalExpr expr
133processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =
134 ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
135evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr
136evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate
137evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do
138 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
139 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
140 pure (AndPredicate exprA' exprB')
141evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) = do
142 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
143 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
144 pure (OrPredicate exprA' exprB')
145evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do
146 let expr' = evalTransGraphRestrictionPredicateExpr expr
147 NotPredicate <$> expr'
148evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do
149 let expr' = processTransGraphRelationalExpr expr
150 RelationalExprPredicate <$> expr'
151evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do
152 let expr' = processTransGraphAtomExpr expr
153 AtomExprPredicate <$> expr'
154evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do
155 let expr' = processTransGraphAtomExpr expr
156 AttributeEqualityPredicate attrName <$> expr'
158processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr
159processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do
160 AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr
162processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr
163processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =
164 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup
165processTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)
167processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames
168processTransGraphAttributeNames (AttributeNames names) = pure (AttributeNames names)
169processTransGraphAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)
170processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do
171 nA <- processTransGraphAttributeNames namesA
172 nB <- processTransGraphAttributeNames namesB
173 pure (UnionAttributeNames nA nB)
174processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do
175 nA <- processTransGraphAttributeNames namesA
176 nB <- processTransGraphAttributeNames namesB
177 pure (IntersectAttributeNames nA nB)
178processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do
179 evaldExpr <- processTransGraphRelationalExpr expr
180 pure (RelationalExprAttributeNames evaldExpr)