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