git.iko.soy/project-m36
on e5bb4e5 help sign in
project-m36/src/lib/ProjectM36/TransGraphRelationalExpression.hs
180 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
14-- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).
15type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup
17type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup
19type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup
21type TransGraphTupleExpr = TupleExprBase TransactionIdLookup
23type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup
25type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup
27type TransGraphAtomExpr = AtomExprBase TransactionIdLookup
29type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup
31type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup
33newtype TransGraphEvalEnv = TransGraphEvalEnv {
34 tge_graph :: TransactionGraph
35 }
37type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a
39process :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr
40process env texpr = runIdentity (runExceptT (runReaderT (processTransGraphRelationalExpr texpr) env))
42liftE :: Either RelationalError a -> TransGraphEvalMonad a
43liftE = lift . except
45askGraph :: TransGraphEvalMonad TransactionGraph
46askGraph = tge_graph <$> ask
48findTransId :: TransactionIdLookup -> TransGraphEvalMonad GraphRefTransactionMarker
49findTransId tlook = TransactionMarker . transactionId <$> findTrans tlook
51findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction
52findTrans tlook = do
53 graph <- askGraph
54 liftE $ lookupTransaction graph tlook
56-- 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.
57processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr
58processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do
59 tupleExprs' <- processTransGraphTupleExprs tupleExprs
60 case mAttrExprs of
61 Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')
62 Just attrExprs -> do
63 attrExprs' <- mapM processTransGraphAttributeExpr attrExprs
64 pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')
65processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
66processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
67processTransGraphRelationalExpr (RelationVariable rvname transLookup) =
68 RelationVariable rvname <$> findTransId transLookup
69processTransGraphRelationalExpr (Project transAttrNames expr) =
70 Project <$> processTransGraphAttributeNames transAttrNames <*> processTransGraphRelationalExpr expr
71processTransGraphRelationalExpr (Union exprA exprB) =
72 Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
73processTransGraphRelationalExpr (Join exprA exprB) =
74 Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
75processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =
76 Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr
77processTransGraphRelationalExpr (Difference exprA exprB) =
78 Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB
79processTransGraphRelationalExpr (Group transAttrNames attrName expr) =
80 Group <$>
81 processTransGraphAttributeNames transAttrNames <*>
82 pure attrName <*>
83 processTransGraphRelationalExpr expr
84processTransGraphRelationalExpr (Ungroup attrName expr) =
85 Ungroup attrName <$> processTransGraphRelationalExpr expr
86processTransGraphRelationalExpr (Restrict predicateExpr expr) =
87 Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>
88 processTransGraphRelationalExpr expr
89processTransGraphRelationalExpr (Equals exprA exprB) = do
90 exprA' <- processTransGraphRelationalExpr exprA
91 exprB' <- processTransGraphRelationalExpr exprB
92 pure (Equals exprA' exprB')
93processTransGraphRelationalExpr (NotEquals exprA exprB) = do
94 exprA' <- processTransGraphRelationalExpr exprA
95 exprB' <- processTransGraphRelationalExpr exprB
96 pure (NotEquals exprA' exprB')
97processTransGraphRelationalExpr (Extend extendExpr expr) = do
98 extendExpr' <- processTransGraphExtendTupleExpr extendExpr
99 expr' <- processTransGraphRelationalExpr expr
100 pure (Extend extendExpr' expr')
101processTransGraphRelationalExpr (With views expr) = do
102 evaldViews <- mapM (\(wnexpr, vexpr) -> do
103 wnexpr' <- processTransGraphWithNameExpr wnexpr
104 vexpr' <- processTransGraphRelationalExpr vexpr
105 pure (wnexpr', vexpr')
106 ) views
107 expr' <- processTransGraphRelationalExpr expr
108 pure (With evaldViews expr')
110processTransGraphTupleExprs :: TransGraphTupleExprs -> TransGraphEvalMonad GraphRefTupleExprs
111processTransGraphTupleExprs (TupleExprs marker texprs) =
112 TupleExprs <$> findTransId marker <*> mapM processTransGraphTupleExpr texprs
114processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr
115processTransGraphTupleExpr (TupleExpr attrMap) = do
116 let attrAssoc = mapM (\(attrName, atomExpr) -> do
117 aExpr <- processTransGraphAtomExpr atomExpr
118 pure (attrName, aExpr)
119 ) (M.toList attrMap)
120 TupleExpr . M.fromList <$> attrAssoc
122processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr
123processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname
124processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
125processTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =
126 FunctionAtomExpr funcName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
127processTransGraphAtomExpr (RelationAtomExpr expr) =
128 RelationAtomExpr <$> processTransGraphRelationalExpr expr
129processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =
130 ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup
131evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr
132evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate
133evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do
134 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
135 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
136 pure (AndPredicate exprA' exprB')
137evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) = do
138 exprA' <- evalTransGraphRestrictionPredicateExpr exprA
139 exprB' <- evalTransGraphRestrictionPredicateExpr exprB
140 pure (OrPredicate exprA' exprB')
141evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do
142 let expr' = evalTransGraphRestrictionPredicateExpr expr
143 NotPredicate <$> expr'
144evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do
145 let expr' = processTransGraphRelationalExpr expr
146 RelationalExprPredicate <$> expr'
147evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do
148 let expr' = processTransGraphAtomExpr expr
149 AtomExprPredicate <$> expr'
150evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do
151 let expr' = processTransGraphAtomExpr expr
152 AttributeEqualityPredicate attrName <$> expr'
154processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr
155processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) =
156 AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr
158processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr
159processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =
160 AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup
161processTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)
163processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames
164processTransGraphAttributeNames (AttributeNames names) = pure (AttributeNames names)
165processTransGraphAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)
166processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do
167 nA <- processTransGraphAttributeNames namesA
168 nB <- processTransGraphAttributeNames namesB
169 pure (UnionAttributeNames nA nB)
170processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do
171 nA <- processTransGraphAttributeNames namesA
172 nB <- processTransGraphAttributeNames namesB
173 pure (IntersectAttributeNames nA nB)
174processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do
175 evaldExpr <- processTransGraphRelationalExpr expr
176 pure (RelationalExprAttributeNames evaldExpr)
178processTransGraphWithNameExpr :: TransGraphWithNameExpr -> TransGraphEvalMonad GraphRefWithNameExpr
179processTransGraphWithNameExpr (WithNameExpr rvname tlookup) =
180 WithNameExpr rvname <$> findTransId tlookup