git.iko.soy/project-m36
on db6f80d help sign in
project-m36/TutorialD/Interpreter/DatabaseExpr.hs
114 lines 3.8 kB history raw
1module TutorialD.Interpreter.DatabaseExpr where
2import Text.Parsec
3import Text.Parsec.String
4import ProjectM36.Base
5import TutorialD.Interpreter.Base
6import qualified Data.Text as T
7import Control.Applicative ((<*), (*>))
8import TutorialD.Interpreter.RelationalExpr
9import qualified Data.Map as M
10import Control.Monad.State
11import ProjectM36.StaticOptimizer
12import ProjectM36.Error
13import ProjectM36.RelationalExpression
15--parsers which create "database expressions" which modify the database context (such as relvar assignment)
16databaseExprP :: Parser DatabaseExpr
17databaseExprP = insertP
18 <|> deleteP
19 <|> updateP
20 <|> constraintP
21 <|> defineP
22 <|> undefineP
23 <|> assignP
25assignP :: Parser DatabaseExpr
26assignP = do
27 relVarName <- try $ do
28 relVarName <- identifier
29 reservedOp ":="
30 return relVarName
31 expr <- relExprP
32 return $ Assign (T.pack relVarName) expr
34multipleDatabaseExprP :: Parser DatabaseExpr
35multipleDatabaseExprP = do
36 exprs <- sepBy1 databaseExprP semi
37 return $ MultipleExpr exprs
39insertP :: Parser DatabaseExpr
40insertP = do
41 reservedOp "insert"
42 relvar <- identifier
43 expr <- relExprP
44 return $ Insert (T.pack relvar) expr
46defineP :: Parser DatabaseExpr
47defineP = do
48 relVarName <- try $ do
49 relVarName <- identifier
50 reservedOp "::"
51 return relVarName
52 attributeSet <- makeAttributesP
53 return $ Define (T.pack relVarName) attributeSet
55undefineP :: Parser DatabaseExpr
56undefineP = do
57 reservedOp "undefine"
58 relVarName <- identifier
59 return $ Undefine (T.pack relVarName)
61deleteP :: Parser DatabaseExpr
62deleteP = do
63 reservedOp "delete"
64 relVarName <- identifier
65 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
66 return $ Delete (T.pack relVarName) predicate
68updateP :: Parser DatabaseExpr
69updateP = do
70 reservedOp "update"
71 relVarName <- identifier
72 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
73 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
74 return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
76constraintP :: Parser DatabaseExpr
77constraintP = do
78 reservedOp "constraint"
79 constraintName <- identifier
80 subset <- relExprP
81 reservedOp "in"
82 superset <- relExprP
83 return $ AddInclusionDependency (InclusionDependency (T.pack constraintName) subset superset)
85attributeAssignmentP :: Parser (String, Atom)
86attributeAssignmentP = do
87 attrName <- identifier
88 reservedOp ":="
89 atom <- stringAtomP <|> intAtomP
90 return $ (attrName, atom)
92databaseExprOpP :: Parser DatabaseExpr
93databaseExprOpP = multipleDatabaseExprP
95evalDatabaseExpr :: Bool -> DatabaseContext -> DatabaseExpr -> Either RelationalError DatabaseContext
96evalDatabaseExpr useOptimizer context expr = do
97 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
98 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
99 (Nothing, context') -> Right context'
100 (Just err, _) -> Left err
103interpretDatabaseExpr :: DatabaseContext -> String -> Either RelationalError DatabaseContext
104interpretDatabaseExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
105 Left err -> Left $ ParseError (T.pack (show err))
106 Right parsed -> evalDatabaseExpr True context parsed
108{-
109--no optimization
110interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
111interpretNO context tutdstring = case parseString tutdstring of
112 Left err -> (Just err, context)
113 Right parsed -> runState (evalContextExpr parsed) context
114-}