git.iko.soy/project-m36
on 51b014d help sign in
project-m36/src/lib/ProjectM36/TransGraphRelationalExpression.hs
190 lines 9.8 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.GraphRefRelationalExpr
9import ProjectM36.RelationalExpression hiding (liftE)
10import ProjectM36.Error
11import ProjectM36.Tuple
12import ProjectM36.AtomType
13import qualified Data.Map as M
14import Control.Monad.Trans.Reader
15import Control.Monad.Trans.Class
16import Control.Monad.Trans.Except
17import Data.Functor.Identity
18import Data.Binary
20-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).
21type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup
23instance Binary TransGraphRelationalExpr
25type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup
27instance Binary TransGraphAttributeNames
29type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup
31instance Binary TransGraphExtendTupleExpr
33type TransGraphTupleExpr = TupleExprBase TransactionIdLookup
35instance Binary TransGraphTupleExpr
37type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup
39instance Binary TransGraphRestrictionPredicateExpr
41type TransGraphAtomExpr = AtomExprBase TransactionIdLookup
43instance Binary TransGraphAtomExpr
45type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup
47data TransGraphEvalEnv = TransGraphEvalEnv { transId :: TransactionId,
48 graph :: TransactionGraph
49 }
51type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a
53run :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr
54run env texpr = runIdentity (runExceptT (runReaderT (evalTransGraphRelationalExpr texpr) env))
56liftE :: Either RelationalError a -> TransGraphEvalMonad a
57liftE = lift . except
60askTid :: TransGraphEvalMonad TransactionId
61askTid = transId <$> ask
63askGraph :: TransGraphEvalMonad TransactionGraph
64askGraph = graph <$> ask
66findTransId :: TransactionIdLookup -> TransGraphEvalMonad TransactionId
67findTransId tlook = transactionId <$> findTrans tlook
69findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction
70findTrans tlook = do
71 graph <- askGraph
72 liftE $ lookupTransaction graph tlook
74-- 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.
75evalTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr
76evalTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
77 tupleExprs' <- mapM evalTransGraphTupleExpr tupleExprs
78 case mAttrExprs of
79 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')
80 Just attrExprs -> do
81 attrExprs' <- mapM evalTransGraphAttributeExpr attrExprs
82 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')
83evalTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
84evalTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
85evalTransGraphRelationalExpr (RelationVariable rvname transLookup) =
86 RelationVariable rvname <$> findTransId transLookup
87evalTransGraphRelationalExpr (Project transAttrNames expr) =
88 Project <$> evalTransAttributeNames transAttrNames <*> evalTransGraphRelationalExpr expr
89evalTransGraphRelationalExpr (Union exprA exprB) =
90 Union <$> evalTransGraphRelationalExpr exprA <*> evalTransGraphRelationalExpr exprB
91evalTransGraphRelationalExpr (Join exprA exprB) =
92 Join <$> evalTransGraphRelationalExpr exprA <*> evalTransGraphRelationalExpr exprB
93evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =
94 Rename attrName1 attrName2 <$> evalTransGraphRelationalExpr expr
95evalTransGraphRelationalExpr (Difference exprA exprB) =
96 Difference <$> evalTransGraphRelationalExpr exprA <*> evalTransGraphRelationalExpr exprB
97evalTransGraphRelationalExpr (Group transAttrNames attrName expr) =
98 Group <$>
99 evalTransAttributeNames transAttrNames <*>
100 pure attrName <*>
101 evalTransGraphRelationalExpr expr
102evalTransGraphRelationalExpr (Ungroup attrName expr) =
103 Ungroup attrName <$> evalTransGraphRelationalExpr expr
104evalTransGraphRelationalExpr (Restrict predicateExpr expr) =
105 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>
106 evalTransGraphRelationalExpr expr
107evalTransGraphRelationalExpr (Equals exprA exprB) = do
108 exprA' <- evalTransGraphRelationalExpr exprA
109 exprB' <- evalTransGraphRelationalExpr exprB
110 pure (Equals exprA' exprB')
111evalTransGraphRelationalExpr (NotEquals exprA exprB) = do
112 exprA' <- evalTransGraphRelationalExpr exprA
113 exprB' <- evalTransGraphRelationalExpr exprB
114 pure (NotEquals exprA' exprB')
115evalTransGraphRelationalExpr (Extend extendExpr expr) = do
116 extendExpr' <- evalTransGraphExtendTupleExpr extendExpr
117 expr' <- evalTransGraphRelationalExpr expr
118 pure (Extend extendExpr' expr')
119evalTransGraphRelationalExpr (With views expr) = do
120 evaldViews <- mapM (\(vname, vexpr) -> do
121 vexpr' <- evalTransGraphRelationalExpr vexpr
122 pure (vname, vexpr')
123 ) views
124 expr' <- evalTransGraphRelationalExpr expr
125 pure (With evaldViews expr')
127evalTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr
128evalTransGraphTupleExpr (TupleExpr attrMap) = do
129 graph <- askGraph
130 let attrAssoc = mapM (\(attrName, atomExpr) -> do
131 aExpr <- evalTransGraphAtomExpr atomExpr
132 pure (attrName, aExpr)
133 ) (M.toList attrMap)
134 TupleExpr . M.fromList <$> attrAssoc
136evalTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr
137evalTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname
138evalTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
139evalTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =
140 FunctionAtomExpr funcName <$> mapM evalTransGraphAtomExpr args <*> findTransId tLookup
141evalTransGraphAtomExpr (RelationAtomExpr expr) =
142 RelationAtomExpr <$> evalTransGraphRelationalExpr expr
143evalTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =
144 ConstructedAtomExpr dConsName <$> mapM evalTransGraphAtomExpr args <*> findTransId tLookup
145evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr
146evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate
147evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do
148 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
149 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
150 pure (AndPredicate exprA' exprB')
151evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) = do
152 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
153 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
154 pure (OrPredicate exprA' exprB')
155evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do
156 let expr' = evalTransGraphRestrictionPredicateExpr expr
157 NotPredicate <$> expr'
158evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do
159 let expr' = evalTransGraphRelationalExpr expr
160 RelationalExprPredicate <$> expr'
161evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do
162 let expr' = evalTransGraphAtomExpr expr
163 AtomExprPredicate <$> expr'
164evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do
165 let expr' = evalTransGraphAtomExpr expr
166 AttributeEqualityPredicate attrName <$> expr'
168evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr
169evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) = do
170 AttributeExtendTupleExpr attrName <$> evalTransGraphAtomExpr expr
172evalTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr
173evalTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =
174 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup
175evalTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)
177evalTransAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames
178evalTransAttributeNames (AttributeNames names) = pure (AttributeNames names)
179evalTransAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)
180evalTransAttributeNames (UnionAttributeNames namesA namesB) = do
181 nA <- evalTransAttributeNames namesA
182 nB <- evalTransAttributeNames namesB
183 pure (UnionAttributeNames nA nB)
184evalTransAttributeNames (IntersectAttributeNames namesA namesB) = do
185 nA <- evalTransAttributeNames namesA
186 nB <- evalTransAttributeNames namesB
187 pure (IntersectAttributeNames nA nB)
188evalTransAttributeNames (RelationalExprAttributeNames expr) = do
189 evaldExpr <- evalTransGraphRelationalExpr expr
190 pure (RelationalExprAttributeNames evaldExpr)