git.iko.soy/project-m36
on e593abd help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
218 lines 7.9 kB history raw
1{-# LANGUAGE CPP #-}
2module TutorialD.Interpreter.DatabaseContextExpr where
3import ProjectM36.Base
4import TutorialD.Interpreter.Base
5import qualified Data.Text as T
6import TutorialD.Interpreter.RelationalExpr
7import TutorialD.Interpreter.Types
8import qualified Data.Map as M
9import ProjectM36.StaticOptimizer
10import qualified ProjectM36.Error as PM36E
11import ProjectM36.Error
12import qualified ProjectM36.RelationalExpression as RE
13import ProjectM36.Key
14import ProjectM36.FunctionalDependency
15#if __GLASGOW_HASKELL__ < 804
16import Data.Monoid
17#endif
18import Data.Functor
20--parsers which create "database expressions" which modify the database context (such as relvar assignment)
21databaseContextExprP :: Parser DatabaseContextExpr
22databaseContextExprP = choice [insertP,
23 deleteConstraintP,
24 deleteP,
25 updateP,
26 addConstraintP,
27 keyP,
28 funcDepP,
29 defineP,
30 undefineP,
31 assignP,
32 addNotificationP,
33 removeNotificationP,
34 addTypeConstructorP,
35 removeTypeConstructorP,
36 removeAtomFunctionP,
37 executeDatabaseContextFunctionP,
38 removeDatabaseContextFunctionP,
39 nothingP]
41nothingP :: Parser DatabaseContextExpr
42nothingP = spaceConsumer >> pure NoOperation
44assignP :: Parser DatabaseContextExpr
45assignP = do
46 relVarName <- try $ do
47 relVarName <- relVarNameP
48 reservedOp ":="
49 return relVarName
50 Assign relVarName <$> relExprP
52multilineSep :: Parser T.Text
53multilineSep = newline >> pure "\n"
55multipleDatabaseContextExprP :: Parser DatabaseContextExpr
56multipleDatabaseContextExprP =
57 MultipleExpr <$> sepBy1 databaseContextExprP semi
59insertP :: Parser DatabaseContextExpr
60insertP = do
61 reservedOp "insert"
62 relvar <- relVarNameP
63 Insert relvar <$> relExprP
65defineP :: Parser DatabaseContextExpr
66defineP = do
67 relVarName <- try $ do
68 relVarName <- relVarNameP
69 reservedOp "::"
70 return relVarName
71 Define relVarName <$> makeAttributeExprsP
73undefineP :: Parser DatabaseContextExpr
74undefineP = do
75 reservedOp "undefine"
76 Undefine <$> relVarNameP
78deleteP :: Parser DatabaseContextExpr
79deleteP = do
80 reservedOp "delete"
81 Delete <$> relVarNameP <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)
83updateP :: Parser DatabaseContextExpr
84updateP = do
85 reservedOp "update"
86 relVarName <- relVarNameP
87 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
88 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
89 return $ Update relVarName attributeAssignments predicate
91data IncDepOp = SubsetOp | EqualityOp
93addConstraintP :: Parser DatabaseContextExpr
94addConstraintP = do
95 reservedOp "constraint" <|> reservedOp "foreign key"
96 constraintName <- identifier
97 subset <- relExprP
98 op <- (reservedOp "in" $> SubsetOp) <|> (reservedOp "equals" $> EqualityOp)
99 superset <- relExprP
100 let subsetA = incDepSet constraintName subset superset
101 subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint
102 incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)
103 case op of
104 SubsetOp -> pure subsetA
105 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
107deleteConstraintP :: Parser DatabaseContextExpr
108deleteConstraintP = do
109 reserved "deleteconstraint"
110 RemoveInclusionDependency <$> identifier
112-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
113keyP :: Parser DatabaseContextExpr
114keyP = do
115 reserved "key"
116 keyName <- identifier
117 uniquenessAttrNames <- braces attributeListP
118 uniquenessExpr <- relExprP
119 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
120 pure $ AddInclusionDependency keyName newIncDep
122funcDepP :: Parser DatabaseContextExpr
123funcDepP = do
124 reserved "funcdep"
125 keyName <- identifier
126 source <- parens attributeListP
127 reserved "->"
128 dependents <- parens attributeListP
129 expr <- relExprP
130 let newIncDeps = inclusionDependenciesForFunctionalDependency funcDep
131 funcDep = FunctionalDependency source dependents expr
132 nameA = keyName <> "_A"
133 nameB = keyName <> "_B"
134 pure (MultipleExpr [AddInclusionDependency nameA (fst newIncDeps),
135 AddInclusionDependency nameB (snd newIncDeps)])
137attributeAssignmentP :: Parser (AttributeName, AtomExpr)
138attributeAssignmentP = do
139 attrName <- identifier
140 reservedOp ":="
141 atomExpr <- atomExprP
142 pure (attrName, atomExpr)
144addNotificationP :: Parser DatabaseContextExpr
145addNotificationP = do
146 reserved "notify"
147 notName <- identifier
148 triggerExpr <- relExprP
149 resultOldExpr <- relExprP
150 AddNotification notName triggerExpr resultOldExpr <$> relExprP
152removeNotificationP :: Parser DatabaseContextExpr
153removeNotificationP = do
154 reserved "unnotify"
155 RemoveNotification <$> identifier
157-- | data Hair = Bald | Color Text
158addTypeConstructorP :: Parser DatabaseContextExpr
159addTypeConstructorP = do
160 reserved "data"
161 typeConstructorDef <- typeConstructorDefP
162 reservedOp "="
163 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
164 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
166removeTypeConstructorP :: Parser DatabaseContextExpr
167removeTypeConstructorP = do
168 reserved "undata"
169 RemoveTypeConstructor <$> typeConstructorNameP
171removeAtomFunctionP :: Parser DatabaseContextExpr
172removeAtomFunctionP = do
173 reserved "removeatomfunction"
174 RemoveAtomFunction <$> quotedString
176removeDatabaseContextFunctionP :: Parser DatabaseContextExpr
177removeDatabaseContextFunctionP = do
178 reserved "removedatabasecontextfunction"
179 RemoveDatabaseContextFunction <$> quotedString
181functionNameP :: Parser AtomFunctionName
182functionNameP = uncapitalizedIdentifier
184executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
185executeDatabaseContextFunctionP = do
186 reserved "execute"
187 funcName <- functionNameP
188 args <- parens (sepBy atomExprP comma)
189 pure (ExecuteDatabaseContextFunction funcName args)
191databaseExprOpP :: Parser DatabaseContextExpr
192databaseExprOpP = multipleDatabaseContextExprP
194{-
195evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
196evalDatabaseContextExpr useOptimizer context expr = do
197 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)
198 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of
199 (Right (), (context',_, _)) -> Right context'
200 (Left err, _) -> Left err
201-}
203interpretDatabaseContextExpr :: DatabaseContext -> TransactionId -> TransactionGraph -> T.Text -> Either RelationalError DatabaseContext
204interpretDatabaseContextExpr context transId graph tutdstring =
205 case parse databaseExprOpP "" tutdstring of
206 Left err -> Left $ PM36E.ParseError (T.pack (show err))
207 Right parsed -> do
208 let env = RE.mkDatabaseContextEvalEnv transId graph
209 RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)
211{-
212--no optimization
213interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
214interpretNO context tutdstring = case parseString tutdstring of
215 Left err -> (Just err, context)
216 Right parsed -> runState (evalContextExpr parsed) context
217-}