git.iko.soy/project-m36
on 62_python_dbapi help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
204 lines 7.2 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 ProjectM36.RelationalExpression
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 nothingP]
37nothingP :: Parser DatabaseContextExpr
38nothingP = spaceConsumer >> pure NoOperation
40assignP :: Parser DatabaseContextExpr
41assignP = do
42 relVarName <- try $ do
43 relVarName <- identifier
44 reservedOp ":="
45 return relVarName
46 expr <- relExprP
47 pure $ Assign relVarName expr
49multilineSep :: Parser T.Text
50multilineSep = newline >> pure "\n"
52multipleDatabaseContextExprP :: Parser DatabaseContextExpr
53multipleDatabaseContextExprP = do
54 exprs <- sepBy1 databaseContextExprP semi
55 pure $ MultipleExpr exprs
57insertP :: Parser DatabaseContextExpr
58insertP = do
59 reservedOp "insert"
60 relvar <- identifier
61 expr <- relExprP
62 pure $ Insert relvar expr
64defineP :: Parser DatabaseContextExpr
65defineP = do
66 relVarName <- try $ do
67 relVarName <- identifier
68 reservedOp "::"
69 return relVarName
70 attributeSet <- makeAttributeExprsP
71 pure $ Define relVarName attributeSet
73undefineP :: Parser DatabaseContextExpr
74undefineP = do
75 reservedOp "undefine"
76 relVarName <- identifier
77 return $ Undefine relVarName
79deleteP :: Parser DatabaseContextExpr
80deleteP = do
81 reservedOp "delete"
82 relVarName <- identifier
83 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
84 return $ Delete relVarName predicate
86updateP :: Parser DatabaseContextExpr
87updateP = do
88 reservedOp "update"
89 relVarName <- identifier
90 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
91 attributeAssignments <- liftM 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" *> pure SubsetOp) <|> (reservedOp "equals" *> pure 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 resultExpr <- relExprP
154 pure $ AddNotification notName triggerExpr resultExpr
156removeNotificationP :: Parser DatabaseContextExpr
157removeNotificationP = do
158 reserved "unnotify"
159 notName <- identifier
160 pure $ RemoveNotification notName
162-- | data Hair = Bald | Color Text
163addTypeConstructorP :: Parser DatabaseContextExpr
164addTypeConstructorP = do
165 reserved "data"
166 typeConstructorDef <- typeConstructorDefP
167 reservedOp "="
168 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
169 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
171removeTypeConstructorP :: Parser DatabaseContextExpr
172removeTypeConstructorP = do
173 reserved "undata"
174 RemoveTypeConstructor <$> identifier
176removeAtomFunctionP :: Parser DatabaseContextExpr
177removeAtomFunctionP = do
178 reserved "removeatomfunction"
179 RemoveAtomFunction <$> quotedString
181databaseExprOpP :: Parser DatabaseContextExpr
182databaseExprOpP = multipleDatabaseContextExprP
184evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
185evalDatabaseContextExpr useOptimizer context expr = do
186 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
187 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
188 (Nothing, context') -> Right context'
189 (Just err, _) -> Left err
192interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
193interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
194 Left err -> Left $ PM36E.ParseError (T.pack (show err))
195 Right parsed -> evalDatabaseContextExpr True context parsed
197{-
198--no optimization
199interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
200interpretNO context tutdstring = case parseString tutdstring of
201 Left err -> (Just err, context)
202 Right parsed -> runState (evalContextExpr parsed) context
203-}