git.iko.soy/project-m36
on c3a4e2d help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
218 lines 7.9 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 =
58 MultipleExpr <$> sepBy1 databaseContextExprP semi
60insertP :: Parser DatabaseContextExpr
61insertP = do
62 reservedOp "insert"
63 relvar <- identifier
64 expr <- relExprP
65 pure $ Insert relvar expr
67defineP :: Parser DatabaseContextExpr
68defineP = do
69 relVarName <- try $ do
70 relVarName <- identifier
71 reservedOp "::"
72 return relVarName
73 attributeSet <- makeAttributeExprsP
74 pure $ Define relVarName attributeSet
76undefineP :: Parser DatabaseContextExpr
77undefineP = do
78 reservedOp "undefine"
79 Undefine <$> identifier
81deleteP :: Parser DatabaseContextExpr
82deleteP = do
83 reservedOp "delete"
84 Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)
86updateP :: Parser DatabaseContextExpr
87updateP = do
88 reservedOp "update"
89 relVarName <- identifier
90 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
91 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
92 return $ Update relVarName attributeAssignments predicate
94data IncDepOp = SubsetOp | EqualityOp
96addConstraintP :: Parser DatabaseContextExpr
97addConstraintP = do
98 reservedOp "constraint" <|> reservedOp "foreign key"
99 constraintName <- identifier
100 subset <- relExprP
101 op <- (reservedOp "in" $> SubsetOp) <|> (reservedOp "equals" $> EqualityOp)
102 superset <- relExprP
103 let subsetA = incDepSet constraintName subset superset
104 subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint
105 incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)
106 case op of
107 SubsetOp -> pure subsetA
108 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
110deleteConstraintP :: Parser DatabaseContextExpr
111deleteConstraintP = do
112 reserved "deleteconstraint"
113 constraintName <- identifier
114 pure $ RemoveInclusionDependency constraintName
116-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
117keyP :: Parser DatabaseContextExpr
118keyP = do
119 reserved "key"
120 keyName <- identifier
121 uniquenessAttrNames <- braces attributeListP
122 uniquenessExpr <- relExprP
123 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
124 pure $ AddInclusionDependency keyName newIncDep
126funcDepP :: Parser DatabaseContextExpr
127funcDepP = do
128 reserved "funcdep"
129 keyName <- identifier
130 source <- parens attributeListP
131 reserved "->"
132 dependents <- parens attributeListP
133 expr <- relExprP
134 let newIncDeps = inclusionDependenciesForFunctionalDependency funcDep
135 funcDep = FunctionalDependency source dependents expr
136 nameA = keyName <> "_A"
137 nameB = keyName <> "_B"
138 pure (MultipleExpr [AddInclusionDependency nameA (fst newIncDeps),
139 AddInclusionDependency nameB (snd newIncDeps)])
141attributeAssignmentP :: Parser (AttributeName, AtomExpr)
142attributeAssignmentP = do
143 attrName <- identifier
144 reservedOp ":="
145 atomExpr <- atomExprP
146 pure (attrName, atomExpr)
148addNotificationP :: Parser DatabaseContextExpr
149addNotificationP = do
150 reserved "notify"
151 notName <- identifier
152 triggerExpr <- relExprP
153 resultOldExpr <- relExprP
154 resultNewExpr <- relExprP
155 pure $ AddNotification notName triggerExpr resultOldExpr resultNewExpr
157removeNotificationP :: Parser DatabaseContextExpr
158removeNotificationP = do
159 reserved "unnotify"
160 notName <- identifier
161 pure $ RemoveNotification notName
163-- | data Hair = Bald | Color Text
164addTypeConstructorP :: Parser DatabaseContextExpr
165addTypeConstructorP = do
166 reserved "data"
167 typeConstructorDef <- typeConstructorDefP
168 reservedOp "="
169 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
170 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
172removeTypeConstructorP :: Parser DatabaseContextExpr
173removeTypeConstructorP = do
174 reserved "undata"
175 RemoveTypeConstructor <$> identifier
177removeAtomFunctionP :: Parser DatabaseContextExpr
178removeAtomFunctionP = do
179 reserved "removeatomfunction"
180 RemoveAtomFunction <$> quotedString
182removeDatabaseContextFunctionP :: Parser DatabaseContextExpr
183removeDatabaseContextFunctionP = do
184 reserved "removedatabasecontextfunction"
185 RemoveDatabaseContextFunction <$> quotedString
187executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
188executeDatabaseContextFunctionP = do
189 reserved "execute"
190 funcName <- identifier
191 args <- parens (sepBy atomExprP comma)
192 pure (ExecuteDatabaseContextFunction funcName args)
194databaseExprOpP :: Parser DatabaseContextExpr
195databaseExprOpP = multipleDatabaseContextExprP
197evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
198evalDatabaseContextExpr useOptimizer context expr = do
199 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)
200 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of
201 (Right (), (context',_, _)) -> Right context'
202 (Left err, _) -> Left err
205interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
206interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
207 Left err -> Left $ PM36E.ParseError (T.pack (show err))
208 Right parsed ->
209 evalDatabaseContextExpr True context 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-}