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