git.iko.soy/project-m36
on fbfa2ea 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
19--parsers which create "database expressions" which modify the database context (such as relvar assignment)
20databaseContextExprP :: Parser DatabaseContextExpr
21databaseContextExprP = choice [insertP,
22 deleteConstraintP,
23 deleteP,
24 updateP,
25 addConstraintP,
26 keyP,
27 funcDepP,
28 defineP,
29 undefineP,
30 assignP,
31 addNotificationP,
32 removeNotificationP,
33 addTypeConstructorP,
34 removeTypeConstructorP,
35 removeAtomFunctionP,
36 executeDatabaseContextFunctionP,
37 removeDatabaseContextFunctionP,
38 nothingP]
40nothingP :: Parser DatabaseContextExpr
41nothingP = spaceConsumer >> pure NoOperation
43assignP :: Parser DatabaseContextExpr
44assignP = do
45 relVarName <- try $ do
46 relVarName <- identifier
47 reservedOp ":="
48 return relVarName
49 expr <- relExprP
50 pure $ Assign relVarName expr
52multilineSep :: Parser T.Text
53multilineSep = newline >> pure "\n"
55multipleDatabaseContextExprP :: Parser DatabaseContextExpr
56multipleDatabaseContextExprP = do
57 exprs <- sepBy1 databaseContextExprP semi
58 pure $ MultipleExpr exprs
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 relVarName <- identifier
80 return $ Undefine relVarName
82deleteP :: Parser DatabaseContextExpr
83deleteP = do
84 reservedOp "delete"
85 relVarName <- identifier
86 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
87 return $ Delete relVarName predicate
89updateP :: Parser DatabaseContextExpr
90updateP = do
91 reservedOp "update"
92 relVarName <- identifier
93 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
94 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
95 return $ Update relVarName attributeAssignments predicate
97data IncDepOp = SubsetOp | EqualityOp
99addConstraintP :: Parser DatabaseContextExpr
100addConstraintP = do
101 reservedOp "constraint" <|> reservedOp "foreign key"
102 constraintName <- identifier
103 subset <- relExprP
104 op <- (reservedOp "in" *> pure SubsetOp) <|> (reservedOp "equals" *> pure EqualityOp)
105 superset <- relExprP
106 let subsetA = incDepSet constraintName subset superset
107 subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint
108 incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)
109 case op of
110 SubsetOp -> pure subsetA
111 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
113deleteConstraintP :: Parser DatabaseContextExpr
114deleteConstraintP = do
115 reserved "deleteconstraint"
116 constraintName <- identifier
117 pure $ RemoveInclusionDependency constraintName
119-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
120keyP :: Parser DatabaseContextExpr
121keyP = do
122 reserved "key"
123 keyName <- identifier
124 uniquenessAttrNames <- braces attributeListP
125 uniquenessExpr <- relExprP
126 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
127 pure $ AddInclusionDependency keyName newIncDep
129funcDepP :: Parser DatabaseContextExpr
130funcDepP = do
131 reserved "funcdep"
132 keyName <- identifier
133 source <- parens attributeListP
134 reserved "->"
135 dependents <- parens attributeListP
136 expr <- relExprP
137 let newIncDeps = inclusionDependenciesForFunctionalDependency funcDep
138 funcDep = FunctionalDependency source dependents expr
139 nameA = keyName <> "_A"
140 nameB = keyName <> "_B"
141 pure (MultipleExpr [AddInclusionDependency nameA (fst newIncDeps),
142 AddInclusionDependency nameB (snd newIncDeps)])
144attributeAssignmentP :: Parser (AttributeName, AtomExpr)
145attributeAssignmentP = do
146 attrName <- identifier
147 reservedOp ":="
148 atomExpr <- atomExprP
149 pure (attrName, atomExpr)
151addNotificationP :: Parser DatabaseContextExpr
152addNotificationP = do
153 reserved "notify"
154 notName <- identifier
155 triggerExpr <- relExprP
156 resultExpr <- relExprP
157 pure $ AddNotification notName triggerExpr resultExpr
159removeNotificationP :: Parser DatabaseContextExpr
160removeNotificationP = do
161 reserved "unnotify"
162 notName <- identifier
163 pure $ RemoveNotification notName
165-- | data Hair = Bald | Color Text
166addTypeConstructorP :: Parser DatabaseContextExpr
167addTypeConstructorP = do
168 reserved "data"
169 typeConstructorDef <- typeConstructorDefP
170 reservedOp "="
171 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
172 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
174removeTypeConstructorP :: Parser DatabaseContextExpr
175removeTypeConstructorP = do
176 reserved "undata"
177 RemoveTypeConstructor <$> identifier
179removeAtomFunctionP :: Parser DatabaseContextExpr
180removeAtomFunctionP = do
181 reserved "removeatomfunction"
182 RemoveAtomFunction <$> quotedString
184removeDatabaseContextFunctionP :: Parser DatabaseContextExpr
185removeDatabaseContextFunctionP = do
186 reserved "removedatabasecontextfunction"
187 RemoveDatabaseContextFunction <$> quotedString
189executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
190executeDatabaseContextFunctionP = do
191 reserved "execute"
192 funcName <- identifier
193 args <- parens (sepBy atomExprP comma)
194 pure (ExecuteDatabaseContextFunction funcName args)
196databaseExprOpP :: Parser DatabaseContextExpr
197databaseExprOpP = multipleDatabaseContextExprP
199evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
200evalDatabaseContextExpr useOptimizer context expr = do
201 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)
202 case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of
203 (Nothing, (context',_, _)) -> Right context'
204 (Just err, _) -> Left err
207interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
208interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
209 Left err -> Left $ PM36E.ParseError (T.pack (show err))
210 Right parsed -> 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-}