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