git.iko.soy/project-m36
on runtime_constructors help sign in
project-m36/TutorialD/Interpreter/DatabaseExpr.hs
183 lines 6.6 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module TutorialD.Interpreter.DatabaseExpr where
3import Text.Parsec
4import Text.Parsec.String
5import ProjectM36.Base
6import TutorialD.Interpreter.Base
7import qualified Data.Text as T
8import TutorialD.Interpreter.RelationalExpr
9import TutorialD.Interpreter.Types
10import qualified Data.Map as M
11import Control.Monad.State
12import ProjectM36.StaticOptimizer
13import ProjectM36.Error
14import ProjectM36.RelationalExpression
15import ProjectM36.Key
17--parsers which create "database expressions" which modify the database context (such as relvar assignment)
18databaseExprP :: Parser DatabaseExpr
19databaseExprP = choice $ map (\p -> p <* optional commentP) [insertP,
20 deleteConstraintP,
21 deleteP,
22 updateP,
23 addConstraintP,
24 keyP,
25 defineP,
26 undefineP,
27 assignP,
28 addNotificationP,
29 removeNotificationP,
30 addTypeConstructorP,
31 removeTypeConstructorP,
32 nothingP]
34commentP :: Parser DatabaseExpr
35commentP = reserved "--" >> manyTill anyChar eof >> pure NoOperation
37nothingP :: Parser DatabaseExpr
38nothingP = whiteSpace >> pure NoOperation
40assignP :: Parser DatabaseExpr
41assignP = do
42 relVarName <- try $ do
43 relVarName <- identifier
44 reservedOp ":="
45 return relVarName
46 expr <- relExprP
47 return $ Assign (T.pack relVarName) expr
49multipleDatabaseExprP :: Parser DatabaseExpr
50multipleDatabaseExprP = do
51 exprs <- sepBy1 databaseExprP semi
52 return $ MultipleExpr exprs
54insertP :: Parser DatabaseExpr
55insertP = do
56 reservedOp "insert"
57 relvar <- identifier
58 expr <- relExprP
59 return $ Insert (T.pack relvar) expr
61defineP :: Parser DatabaseExpr
62defineP = do
63 relVarName <- try $ do
64 relVarName <- identifier
65 reservedOp "::"
66 return relVarName
67 attributeSet <- makeAttributeExprsP
68 return $ Define (T.pack relVarName) attributeSet
70undefineP :: Parser DatabaseExpr
71undefineP = do
72 reservedOp "undefine"
73 relVarName <- identifier
74 return $ Undefine (T.pack relVarName)
76deleteP :: Parser DatabaseExpr
77deleteP = do
78 reservedOp "delete"
79 relVarName <- identifier
80 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
81 return $ Delete (T.pack relVarName) predicate
83updateP :: Parser DatabaseExpr
84updateP = do
85 reservedOp "update"
86 relVarName <- identifier
87 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
88 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
89 return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
91data IncDepOp = SubsetOp | EqualityOp
93addConstraintP :: Parser DatabaseExpr
94addConstraintP = do
95 reservedOp "constraint" <|> reservedOp "foreign key"
96 constraintName <- identifier
97 subset <- relExprP
98 op <- (reservedOp "in" *> pure SubsetOp) <|> (reservedOp "equals" *> pure EqualityOp)
99 superset <- relExprP
100 let subsetA = incDepSet constraintName subset superset
101 subsetB = incDepSet (constraintName ++ "_eqInvert") superset subset --inverted args for equality constraint
102 incDepSet nam a b = AddInclusionDependency (T.pack nam) (InclusionDependency a b)
103 case op of
104 SubsetOp -> pure subsetA
105 EqualityOp -> pure (MultipleExpr [subsetA, subsetB])
109deleteConstraintP :: Parser DatabaseExpr
110deleteConstraintP = do
111 reserved "deleteconstraint"
112 constraintName <- identifier
113 return $ RemoveInclusionDependency (T.pack constraintName)
115-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
116keyP :: Parser DatabaseExpr
117keyP = do
118 reserved "key"
119 keyName <- identifier
120 uniquenessAttrNames <- braces attributeListP
121 uniquenessExpr <- relExprP
122 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
123 return $ AddInclusionDependency (T.pack keyName) newIncDep
125attributeAssignmentP :: Parser (String, Atom)
126attributeAssignmentP = do
127 attrName <- identifier
128 reservedOp ":="
129 atom <- stringAtomP <|> intAtomP
130 return $ (attrName, atom)
132addNotificationP :: Parser DatabaseExpr
133addNotificationP = do
134 reserved "notify"
135 notName <- identifier
136 triggerExpr <- relExprP
137 resultExpr <- relExprP
138 return $ AddNotification (T.pack notName) triggerExpr resultExpr
140removeNotificationP :: Parser DatabaseExpr
141removeNotificationP = do
142 reserved "unnotify"
143 notName <- identifier
144 return $ RemoveNotification (T.pack notName)
146-- | data Hair = Bald | Color Text
147addTypeConstructorP :: Parser DatabaseExpr
148addTypeConstructorP = do
149 reserved "data"
150 typeConstructorDef <- typeConstructorDefP
151 reservedOp "="
152 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
153 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
155removeTypeConstructorP :: Parser DatabaseExpr
156removeTypeConstructorP = do
157 reserved "undata"
158 RemoveTypeConstructor <$> liftM T.pack identifier
160databaseExprOpP :: Parser DatabaseExpr
161databaseExprOpP = multipleDatabaseExprP
163evalDatabaseExpr :: Bool -> DatabaseContext -> DatabaseExpr -> Either RelationalError DatabaseContext
164evalDatabaseExpr useOptimizer context expr = do
165 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
166 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
167 (Nothing, context') -> Right context'
168 (Just err, _) -> Left err
171interpretDatabaseExpr :: DatabaseContext -> String -> Either RelationalError DatabaseContext
172interpretDatabaseExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
173 Left err -> Left $ ParseError (T.pack (show err))
174 Right parsed -> evalDatabaseExpr True context parsed
176{-
177--no optimization
178interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
179interpretNO context tutdstring = case parseString tutdstring of
180 Left err -> (Just err, context)
181 Right parsed -> runState (evalContextExpr parsed) context
182-}