git.iko.soy/project-m36
on fe735ff help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
222 lines 8.0 kB history raw
1module TutorialD.Interpreter.DatabaseContextExpr where
2import Text.Megaparsec
3import Text.Megaparsec.Text
4import ProjectM36.Base
5import TutorialD.Interpreter.Base
6import qualified Data.Text as T
7import TutorialD.Interpreter.RelationalExpr
8import TutorialD.Interpreter.Types
9import qualified Data.Map as M
10import Control.Monad.State
11import ProjectM36.StaticOptimizer
12import qualified ProjectM36.Error as PM36E
13import ProjectM36.Error
14import qualified ProjectM36.RelationalExpression as RE
15import ProjectM36.Key
16import ProjectM36.FunctionalDependency
17import Data.Monoid
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 <- identifier
48 reservedOp ":="
49 return relVarName
50 expr <- relExprP
51 pure $ Assign relVarName expr
53multilineSep :: Parser T.Text
54multilineSep = newline >> pure "\n"
56multipleDatabaseContextExprP :: Parser DatabaseContextExpr
57multipleDatabaseContextExprP = do
58 exprs <- sepBy1 databaseContextExprP semi
59 pure $ MultipleExpr exprs
61insertP :: Parser DatabaseContextExpr
62insertP = do
63 reservedOp "insert"
64 relvar <- identifier
65 expr <- relExprP
66 pure $ Insert relvar expr
68defineP :: Parser DatabaseContextExpr
69defineP = do
70 relVarName <- try $ do
71 relVarName <- identifier
72 reservedOp "::"
73 return relVarName
74 attributeSet <- makeAttributeExprsP
75 pure $ Define relVarName attributeSet
77undefineP :: Parser DatabaseContextExpr
78undefineP = do
79 reservedOp "undefine"
80 relVarName <- identifier
81 return $ Undefine relVarName
83deleteP :: Parser DatabaseContextExpr
84deleteP = do
85 reservedOp "delete"
86 relVarName <- identifier
87 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
88 return $ Delete relVarName predicate
90updateP :: Parser DatabaseContextExpr
91updateP = do
92 reservedOp "update"
93 relVarName <- identifier
94 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
95 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
96 return $ Update relVarName attributeAssignments predicate
98data IncDepOp = SubsetOp | EqualityOp
100addConstraintP :: Parser DatabaseContextExpr
101addConstraintP = do
102 reservedOp "constraint" <|> reservedOp "foreign key"
103 constraintName <- identifier
104 subset <- relExprP
105 op <- (reservedOp "in" $> SubsetOp) <|> (reservedOp "equals" $> EqualityOp)
106 superset <- relExprP
107 let subsetA = incDepSet constraintName subset superset
108 subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint
109 incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)
110 case op of
111 SubsetOp -> pure subsetA
112 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
114deleteConstraintP :: Parser DatabaseContextExpr
115deleteConstraintP = do
116 reserved "deleteconstraint"
117 constraintName <- identifier
118 pure $ RemoveInclusionDependency constraintName
120-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
121keyP :: Parser DatabaseContextExpr
122keyP = do
123 reserved "key"
124 keyName <- identifier
125 uniquenessAttrNames <- braces attributeListP
126 uniquenessExpr <- relExprP
127 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
128 pure $ AddInclusionDependency keyName newIncDep
130funcDepP :: Parser DatabaseContextExpr
131funcDepP = do
132 reserved "funcdep"
133 keyName <- identifier
134 source <- parens attributeListP
135 reserved "->"
136 dependents <- parens attributeListP
137 expr <- relExprP
138 let newIncDeps = inclusionDependenciesForFunctionalDependency funcDep
139 funcDep = FunctionalDependency source dependents expr
140 nameA = keyName <> "_A"
141 nameB = keyName <> "_B"
142 pure (MultipleExpr [AddInclusionDependency nameA (fst newIncDeps),
143 AddInclusionDependency nameB (snd newIncDeps)])
145attributeAssignmentP :: Parser (AttributeName, AtomExpr)
146attributeAssignmentP = do
147 attrName <- identifier
148 reservedOp ":="
149 atomExpr <- atomExprP
150 pure (attrName, atomExpr)
152addNotificationP :: Parser DatabaseContextExpr
153addNotificationP = do
154 reserved "notify"
155 notName <- identifier
156 triggerExpr <- relExprP
157 resultOldExpr <- relExprP
158 resultNewExpr <- relExprP
159 pure $ AddNotification notName triggerExpr resultOldExpr resultNewExpr
161removeNotificationP :: Parser DatabaseContextExpr
162removeNotificationP = do
163 reserved "unnotify"
164 notName <- identifier
165 pure $ RemoveNotification notName
167-- | data Hair = Bald | Color Text
168addTypeConstructorP :: Parser DatabaseContextExpr
169addTypeConstructorP = do
170 reserved "data"
171 typeConstructorDef <- typeConstructorDefP
172 reservedOp "="
173 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
174 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
176removeTypeConstructorP :: Parser DatabaseContextExpr
177removeTypeConstructorP = do
178 reserved "undata"
179 RemoveTypeConstructor <$> identifier
181removeAtomFunctionP :: Parser DatabaseContextExpr
182removeAtomFunctionP = do
183 reserved "removeatomfunction"
184 RemoveAtomFunction <$> quotedString
186removeDatabaseContextFunctionP :: Parser DatabaseContextExpr
187removeDatabaseContextFunctionP = do
188 reserved "removedatabasecontextfunction"
189 RemoveDatabaseContextFunction <$> quotedString
191executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
192executeDatabaseContextFunctionP = do
193 reserved "execute"
194 funcName <- identifier
195 args <- parens (sepBy atomExprP comma)
196 pure (ExecuteDatabaseContextFunction funcName args)
198databaseExprOpP :: Parser DatabaseContextExpr
199databaseExprOpP = multipleDatabaseContextExprP
201evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
202evalDatabaseContextExpr useOptimizer context expr = do
203 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)
204 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of
205 (Right (), (context',_, _)) -> Right context'
206 (Left err, _) -> Left err
209interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
210interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
211 Left err -> Left $ PM36E.ParseError (T.pack (show err))
212 Right parsed ->
213 evalDatabaseContextExpr True context parsed
215{-
216--no optimization
217interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
218interpretNO context tutdstring = case parseString tutdstring of
219 Left err -> (Just err, context)
220 Right parsed -> runState (evalContextExpr parsed) context
221-}