git.iko.soy/project-m36
on 8cfc3ee help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
187 lines 6.6 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 Data.Monoid
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 defineP,
27 undefineP,
28 assignP,
29 addNotificationP,
30 removeNotificationP,
31 addTypeConstructorP,
32 removeTypeConstructorP,
33 nothingP]
35nothingP :: Parser DatabaseContextExpr
36nothingP = spaceConsumer >> pure NoOperation
38assignP :: Parser DatabaseContextExpr
39assignP = do
40 relVarName <- try $ do
41 relVarName <- identifier
42 reservedOp ":="
43 return relVarName
44 expr <- relExprP
45 pure $ Assign relVarName expr
47multilineSep :: Parser T.Text
48multilineSep = newline >> pure "\n"
50multipleDatabaseContextExprP :: Parser DatabaseContextExpr
51multipleDatabaseContextExprP = do
52 exprs <- sepBy1 databaseContextExprP semi
53 pure $ MultipleExpr exprs
55insertP :: Parser DatabaseContextExpr
56insertP = do
57 reservedOp "insert"
58 relvar <- identifier
59 expr <- relExprP
60 pure $ Insert relvar expr
62defineP :: Parser DatabaseContextExpr
63defineP = do
64 relVarName <- try $ do
65 relVarName <- identifier
66 reservedOp "::"
67 return relVarName
68 attributeSet <- makeAttributeExprsP
69 pure $ Define relVarName attributeSet
71undefineP :: Parser DatabaseContextExpr
72undefineP = do
73 reservedOp "undefine"
74 relVarName <- identifier
75 return $ Undefine relVarName
77deleteP :: Parser DatabaseContextExpr
78deleteP = do
79 reservedOp "delete"
80 relVarName <- identifier
81 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
82 return $ Delete relVarName predicate
84updateP :: Parser DatabaseContextExpr
85updateP = do
86 reservedOp "update"
87 relVarName <- identifier
88 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
89 attributeAssignments <- liftM 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" *> pure SubsetOp) <|> (reservedOp "equals" *> pure 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 constraintName <- identifier
112 pure $ RemoveInclusionDependency constraintName
114-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
115keyP :: Parser DatabaseContextExpr
116keyP = do
117 reserved "key"
118 keyName <- identifier
119 uniquenessAttrNames <- braces attributeListP
120 uniquenessExpr <- relExprP
121 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
122 pure $ AddInclusionDependency keyName newIncDep
124attributeAssignmentP :: Parser (AttributeName, AtomExpr)
125attributeAssignmentP = do
126 attrName <- identifier
127 reservedOp ":="
128 atomExpr <- atomExprP
129 pure $ (attrName, atomExpr)
131addNotificationP :: Parser DatabaseContextExpr
132addNotificationP = do
133 reserved "notify"
134 notName <- identifier
135 triggerExpr <- relExprP
136 resultExpr <- relExprP
137 pure $ AddNotification notName triggerExpr resultExpr
139removeNotificationP :: Parser DatabaseContextExpr
140removeNotificationP = do
141 reserved "unnotify"
142 notName <- identifier
143 pure $ RemoveNotification notName
145-- | data Hair = Bald | Color Text
146addTypeConstructorP :: Parser DatabaseContextExpr
147addTypeConstructorP = do
148 reserved "data"
149 typeConstructorDef <- typeConstructorDefP
150 reservedOp "="
151 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
152 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
154removeTypeConstructorP :: Parser DatabaseContextExpr
155removeTypeConstructorP = do
156 reserved "undata"
157 RemoveTypeConstructor <$> identifier
159removeAtomFunctionP :: Parser DatabaseContextExpr
160removeAtomFunctionP = do
161 reserved "removeatomfunction"
162 RemoveAtomFunction <$> quotedString
164databaseExprOpP :: Parser DatabaseContextExpr
165databaseExprOpP = multipleDatabaseContextExprP
167evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
168evalDatabaseContextExpr useOptimizer context expr = do
169 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
170 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
171 (Nothing, context') -> Right context'
172 (Just err, _) -> Left err
175interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
176interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
177 Left err -> Left $ PM36E.ParseError (T.pack (show err))
178 Right parsed -> evalDatabaseContextExpr True context parsed
180{-
181--no optimization
182interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
183interpretNO context tutdstring = case parseString tutdstring of
184 Left err -> (Just err, context)
185 Right parsed -> runState (evalContextExpr parsed) context
186-}