git.iko.soy/project-m36
on e0e000c help sign in
project-m36/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs
190 lines 6.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 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 $ map (\p -> p <* optional commentP) [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]
35commentP :: Parser DatabaseContextExpr
36commentP = reserved "--" >> manyTill anyChar eof >> pure NoOperation
38nothingP :: Parser DatabaseContextExpr
39nothingP = spaceConsumer >> pure NoOperation
41assignP :: Parser DatabaseContextExpr
42assignP = do
43 relVarName <- try $ do
44 relVarName <- identifier
45 reservedOp ":="
46 return relVarName
47 expr <- relExprP
48 pure $ Assign relVarName expr
50multilineSep :: Parser T.Text
51multilineSep = newline >> pure "\n"
53multipleDatabaseContextExprP :: Parser DatabaseContextExpr
54multipleDatabaseContextExprP = do
55 exprs <- sepBy1 databaseContextExprP semi
56 pure $ MultipleExpr exprs
58insertP :: Parser DatabaseContextExpr
59insertP = do
60 reservedOp "insert"
61 relvar <- identifier
62 expr <- relExprP
63 pure $ Insert relvar expr
65defineP :: Parser DatabaseContextExpr
66defineP = do
67 relVarName <- try $ do
68 relVarName <- identifier
69 reservedOp "::"
70 return relVarName
71 attributeSet <- makeAttributeExprsP
72 pure $ Define relVarName attributeSet
74undefineP :: Parser DatabaseContextExpr
75undefineP = do
76 reservedOp "undefine"
77 relVarName <- identifier
78 return $ Undefine relVarName
80deleteP :: Parser DatabaseContextExpr
81deleteP = do
82 reservedOp "delete"
83 relVarName <- identifier
84 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
85 return $ Delete relVarName predicate
87updateP :: Parser DatabaseContextExpr
88updateP = do
89 reservedOp "update"
90 relVarName <- identifier
91 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
92 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
93 return $ Update relVarName attributeAssignments predicate
95data IncDepOp = SubsetOp | EqualityOp
97addConstraintP :: Parser DatabaseContextExpr
98addConstraintP = do
99 reservedOp "constraint" <|> reservedOp "foreign key"
100 constraintName <- identifier
101 subset <- relExprP
102 op <- (reservedOp "in" *> pure SubsetOp) <|> (reservedOp "equals" *> pure EqualityOp)
103 superset <- relExprP
104 let subsetA = incDepSet constraintName subset superset
105 subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint
106 incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)
107 case op of
108 SubsetOp -> pure subsetA
109 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
111deleteConstraintP :: Parser DatabaseContextExpr
112deleteConstraintP = do
113 reserved "deleteconstraint"
114 constraintName <- identifier
115 pure $ RemoveInclusionDependency constraintName
117-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
118keyP :: Parser DatabaseContextExpr
119keyP = do
120 reserved "key"
121 keyName <- identifier
122 uniquenessAttrNames <- braces attributeListP
123 uniquenessExpr <- relExprP
124 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
125 pure $ AddInclusionDependency keyName newIncDep
127attributeAssignmentP :: Parser (AttributeName, AtomExpr)
128attributeAssignmentP = do
129 attrName <- identifier
130 reservedOp ":="
131 atomExpr <- atomExprP
132 pure $ (attrName, atomExpr)
134addNotificationP :: Parser DatabaseContextExpr
135addNotificationP = do
136 reserved "notify"
137 notName <- identifier
138 triggerExpr <- relExprP
139 resultExpr <- relExprP
140 pure $ AddNotification notName triggerExpr resultExpr
142removeNotificationP :: Parser DatabaseContextExpr
143removeNotificationP = do
144 reserved "unnotify"
145 notName <- identifier
146 pure $ RemoveNotification notName
148-- | data Hair = Bald | Color Text
149addTypeConstructorP :: Parser DatabaseContextExpr
150addTypeConstructorP = do
151 reserved "data"
152 typeConstructorDef <- typeConstructorDefP
153 reservedOp "="
154 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
155 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
157removeTypeConstructorP :: Parser DatabaseContextExpr
158removeTypeConstructorP = do
159 reserved "undata"
160 RemoveTypeConstructor <$> identifier
162removeAtomFunctionP :: Parser DatabaseContextExpr
163removeAtomFunctionP = do
164 reserved "removeatomfunction"
165 RemoveAtomFunction <$> quotedString
167databaseExprOpP :: Parser DatabaseContextExpr
168databaseExprOpP = multipleDatabaseContextExprP
170evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext
171evalDatabaseContextExpr useOptimizer context expr = do
172 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
173 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
174 (Nothing, context') -> Right context'
175 (Just err, _) -> Left err
178interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext
179interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
180 Left err -> Left $ PM36E.ParseError (T.pack (show err))
181 Right parsed -> evalDatabaseContextExpr True context parsed
183{-
184--no optimization
185interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
186interpretNO context tutdstring = case parseString tutdstring of
187 Left err -> (Just err, context)
188 Right parsed -> runState (evalContextExpr parsed) context
189-}