git.iko.soy/project-m36
on 574ffd5 help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
219 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 = 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 Undefine <$> identifier
82deleteP :: Parser DatabaseContextExpr
83deleteP = do
84 reservedOp "delete"
85 Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)
87updateP :: Parser DatabaseContextExpr
88updateP = do
89 reservedOp "update"
90 relVarName <- identifier
91 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
92 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
93 return $ Update relVarName attributeAssignments predicate
95data IncDepOp = SubsetOp | EqualityOp
97addConstraintP :: Parser DatabaseContextExpr
98addConstraintP = do
99 reservedOp "constraint" <|> reservedOp "foreign key"
100 constraintName <- identifier
101 subset <- relExprP
102 op <- (reservedOp "in" $> SubsetOp) <|> (reservedOp "equals" $> EqualityOp)
103 superset <- relExprP
104 let subsetA = incDepSet constraintName subset superset
105 subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint
106 incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)
107 case op of
108 SubsetOp -> pure subsetA
109 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
111deleteConstraintP :: Parser DatabaseContextExpr
112deleteConstraintP = do
113 reserved "deleteconstraint"
114 constraintName <- identifier
115 pure $ RemoveInclusionDependency constraintName
117-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
118keyP :: Parser DatabaseContextExpr
119keyP = do
120 reserved "key"
121 keyName <- identifier
122 uniquenessAttrNames <- braces attributeListP
123 uniquenessExpr <- relExprP
124 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
125 pure $ AddInclusionDependency keyName newIncDep
127funcDepP :: Parser DatabaseContextExpr
128funcDepP = do
129 reserved "funcdep"
130 keyName <- identifier
131 source <- parens attributeListP
132 reserved "->"
133 dependents <- parens attributeListP
134 expr <- relExprP
135 let newIncDeps = inclusionDependenciesForFunctionalDependency funcDep
136 funcDep = FunctionalDependency source dependents expr
137 nameA = keyName <> "_A"
138 nameB = keyName <> "_B"
139 pure (MultipleExpr [AddInclusionDependency nameA (fst newIncDeps),
140 AddInclusionDependency nameB (snd newIncDeps)])
142attributeAssignmentP :: Parser (AttributeName, AtomExpr)
143attributeAssignmentP = do
144 attrName <- identifier
145 reservedOp ":="
146 atomExpr <- atomExprP
147 pure (attrName, atomExpr)
149addNotificationP :: Parser DatabaseContextExpr
150addNotificationP = do
151 reserved "notify"
152 notName <- identifier
153 triggerExpr <- relExprP
154 resultOldExpr <- relExprP
155 resultNewExpr <- relExprP
156 pure $ AddNotification notName triggerExpr resultOldExpr resultNewExpr
158removeNotificationP :: Parser DatabaseContextExpr
159removeNotificationP = do
160 reserved "unnotify"
161 notName <- identifier
162 pure $ RemoveNotification notName
164-- | data Hair = Bald | Color Text
165addTypeConstructorP :: Parser DatabaseContextExpr
166addTypeConstructorP = do
167 reserved "data"
168 typeConstructorDef <- typeConstructorDefP
169 reservedOp "="
170 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
171 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
173removeTypeConstructorP :: Parser DatabaseContextExpr
174removeTypeConstructorP = do
175 reserved "undata"
176 RemoveTypeConstructor <$> identifier
178removeAtomFunctionP :: Parser DatabaseContextExpr
179removeAtomFunctionP = do
180 reserved "removeatomfunction"
181 RemoveAtomFunction <$> quotedString
183removeDatabaseContextFunctionP :: Parser DatabaseContextExpr
184removeDatabaseContextFunctionP = do
185 reserved "removedatabasecontextfunction"
186 RemoveDatabaseContextFunction <$> quotedString
188executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
189executeDatabaseContextFunctionP = do
190 reserved "execute"
191 funcName <- identifier
192 args <- parens (sepBy atomExprP comma)
193 pure (ExecuteDatabaseContextFunction funcName args)
195databaseExprOpP :: Parser DatabaseContextExpr
196databaseExprOpP = multipleDatabaseContextExprP
198evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
199evalDatabaseContextExpr useOptimizer context expr = do
200 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)
201 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of
202 (Right (), (context',_, _)) -> Right context'
203 (Left err, _) -> Left err
206interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
207interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
208 Left err -> Left $ PM36E.ParseError (T.pack (show err))
209 Right parsed ->
210 evalDatabaseContextExpr True context parsed
212{-
213--no optimization
214interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
215interpretNO context tutdstring = case parseString tutdstring of
216 Left err -> (Just err, context)
217 Right parsed -> runState (evalContextExpr parsed) context
218-}