git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/lib/ProjectM36/NormalizeExpr.hs
132 lines 8.2 kB history raw
1-- | Functions to convert all types of expresions into their GraphRef- equivalents.
2module ProjectM36.NormalizeExpr where
3import ProjectM36.Base
4import Control.Monad.Trans.Reader as R
5import qualified Data.Map as M
7--used to process/normalize exprs to their respective graph ref forms
8type ProcessExprM a = Reader GraphRefTransactionMarker a
10type CurrentTransactionId = TransactionId
12runProcessExprM :: GraphRefTransactionMarker -> ProcessExprM a -> a
13runProcessExprM mtid m = runReader m mtid
15askMarker :: ProcessExprM GraphRefTransactionMarker
16askMarker = R.ask
18-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id
19processRelationalExpr :: RelationalExpr -> ProcessExprM GraphRefRelationalExpr
20processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do
21 mAttrs' <- case mAttrs of
22 Nothing -> pure Nothing
23 Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''
24 MakeRelationFromExprs mAttrs' <$> processTupleExprs tupleExprs
25processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)
26processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)
27--requires current trans id and graph
28processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMarker
29processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr
30processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB
31processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB
32processRelationalExpr (Rename attrA attrB expr) =
33 Rename attrA attrB <$> processRelationalExpr expr
34processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB
35processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr
36processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr
37processRelationalExpr (Restrict pred' expr) = Restrict <$> processRestrictionPredicateExpr pred' <*> processRelationalExpr expr
38processRelationalExpr (Equals exprA exprB) =
39 Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
40processRelationalExpr (NotEquals exprA exprB) =
41 NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB
42processRelationalExpr (Extend extendExpr expr) =
43 Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr
44processRelationalExpr (With macros expr) =
45 With <$> mapM (\(wnexpr, macroExpr) -> (,) <$> processWithNameExpr wnexpr <*> processRelationalExpr macroExpr) macros <*> processRelationalExpr expr
47processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr
48processWithNameExpr (WithNameExpr rvname ()) =
49 WithNameExpr rvname <$> askMarker
51processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames
52processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet
53processAttributeNames (InvertedAttributeNames attrNameSet) =
54 pure $ InvertedAttributeNames attrNameSet
55processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
56processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB
57processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr
59processDatabaseContextExpr :: DatabaseContextExpr -> ProcessExprM GraphRefDatabaseContextExpr
60processDatabaseContextExpr expr =
61 case expr of
62 NoOperation -> pure NoOperation
63 Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs
64 Undefine nam -> pure (Undefine nam)
65 Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr
66 Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr
67 Delete nam pred' -> Delete nam <$> processRestrictionPredicateExpr pred'
68 Update nam attrMap pred' -> Update nam attrMap <$> processRestrictionPredicateExpr pred'
70 AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)
71 RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)
72 AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)
73 RemoveNotification nam -> pure (RemoveNotification nam)
74 AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)
75 RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)
77 RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)
78 RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)
79 ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs
80 MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs
82processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr
83processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =
84 pure (AddAtomFunction f tcs sc)
85processDatabaseContextIOExpr (LoadAtomFunctions mod' fun file) =
86 pure (LoadAtomFunctions mod' fun file)
87processDatabaseContextIOExpr (AddDatabaseContextFunction mod' fun path) =
88 pure (AddDatabaseContextFunction mod' fun path)
89processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod' fun path) =
90 pure (LoadDatabaseContextFunctions mod' fun path)
91processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =
92 CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range
94processRestrictionPredicateExpr :: RestrictionPredicateExpr -> ProcessExprM GraphRefRestrictionPredicateExpr
95processRestrictionPredicateExpr TruePredicate = pure TruePredicate
96processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
97processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b
98processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a
99processRestrictionPredicateExpr (RelationalExprPredicate expr) =
100 RelationalExprPredicate <$> processRelationalExpr expr
101processRestrictionPredicateExpr (AtomExprPredicate expr) =
102 AtomExprPredicate <$> processAtomExpr expr
103processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =
104 AttributeEqualityPredicate nam <$> processAtomExpr expr
106processExtendTupleExpr :: ExtendTupleExpr -> ProcessExprM GraphRefExtendTupleExpr
107processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =
108 AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr
110processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr
111processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam
112processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom
113processAtomExpr (FunctionAtomExpr fName atomExprs ()) =
114 FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs <*> askMarker
115processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr
116processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker
118processTupleExprs :: TupleExprs -> ProcessExprM GraphRefTupleExprs
119processTupleExprs (TupleExprs () tupleExprs) = do
120 marker <- askMarker
121 TupleExprs marker <$> mapM processTupleExpr tupleExprs
123processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr
124processTupleExpr (TupleExpr tMap) =
125 TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)
127--convert AttributeExpr to GraphRefAttributeExpr
128processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr
129processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =
130 AttributeAndTypeNameExpr nam tCons <$> askMarker
131processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr