git.iko.soy/project-m36
on b2fbc13 help sign in
project-m36/TutorialD/Interpreter/DatabaseExpr.hs
134 lines 4.5 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 Control.Applicative ((<*), (*>))
9import TutorialD.Interpreter.RelationalExpr
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 = insertP
20 <|> deleteConstraintP
21 <|> deleteP
22 <|> updateP
23 <|> addConstraintP
24 <|> keyP
25 <|> defineP
26 <|> undefineP
27 <|> assignP
29assignP :: Parser DatabaseExpr
30assignP = do
31 relVarName <- try $ do
32 relVarName <- identifier
33 reservedOp ":="
34 return relVarName
35 expr <- relExprP
36 return $ Assign (T.pack relVarName) expr
38multipleDatabaseExprP :: Parser DatabaseExpr
39multipleDatabaseExprP = do
40 exprs <- sepBy1 databaseExprP semi
41 return $ MultipleExpr exprs
43insertP :: Parser DatabaseExpr
44insertP = do
45 reservedOp "insert"
46 relvar <- identifier
47 expr <- relExprP
48 return $ Insert (T.pack relvar) expr
50defineP :: Parser DatabaseExpr
51defineP = do
52 relVarName <- try $ do
53 relVarName <- identifier
54 reservedOp "::"
55 return relVarName
56 attributeSet <- makeAttributesP
57 return $ Define (T.pack relVarName) attributeSet
59undefineP :: Parser DatabaseExpr
60undefineP = do
61 reservedOp "undefine"
62 relVarName <- identifier
63 return $ Undefine (T.pack relVarName)
65deleteP :: Parser DatabaseExpr
66deleteP = do
67 reservedOp "delete"
68 relVarName <- identifier
69 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
70 return $ Delete (T.pack relVarName) predicate
72updateP :: Parser DatabaseExpr
73updateP = do
74 reservedOp "update"
75 relVarName <- identifier
76 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
77 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
78 return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
80addConstraintP :: Parser DatabaseExpr
81addConstraintP = do
82 reservedOp "constraint" <|> reservedOp "foreign key"
83 constraintName <- identifier
84 subset <- relExprP
85 reservedOp "in"
86 superset <- relExprP
87 return $ AddInclusionDependency (T.pack constraintName) (InclusionDependency subset superset)
89deleteConstraintP :: Parser DatabaseExpr
90deleteConstraintP = do
91 reserved "deleteconstraint"
92 constraintName <- identifier
93 return $ RemoveInclusionDependency (T.pack constraintName)
95-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
96keyP :: Parser DatabaseExpr
97keyP = do
98 reserved "key"
99 keyName <- identifier
100 uniquenessAttrNames <- braces attributeListP
101 uniquenessExpr <- relExprP
102 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
103 return $ AddInclusionDependency (T.pack keyName) newIncDep
105attributeAssignmentP :: Parser (String, Atom)
106attributeAssignmentP = do
107 attrName <- identifier
108 reservedOp ":="
109 atom <- stringAtomP <|> intAtomP
110 return $ (attrName, atom)
112databaseExprOpP :: Parser DatabaseExpr
113databaseExprOpP = multipleDatabaseExprP
115evalDatabaseExpr :: Bool -> DatabaseContext -> DatabaseExpr -> Either RelationalError DatabaseContext
116evalDatabaseExpr useOptimizer context expr = do
117 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
118 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
119 (Nothing, context') -> Right context'
120 (Just err, _) -> Left err
123interpretDatabaseExpr :: DatabaseContext -> String -> Either RelationalError DatabaseContext
124interpretDatabaseExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
125 Left err -> Left $ ParseError (T.pack (show err))
126 Right parsed -> evalDatabaseExpr True context parsed
128{-
129--no optimization
130interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
131interpretNO context tutdstring = case parseString tutdstring of
132 Left err -> (Just err, context)
133 Right parsed -> runState (evalContextExpr parsed) context
134-}