git.iko.soy/project-m36
on 7bc78ff help sign in
project-m36/TutorialD/Interpreter/DatabaseExpr.hs
133 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 TutorialD.Interpreter.RelationalExpr
9import qualified Data.Map as M
10import Control.Monad.State
11import ProjectM36.StaticOptimizer
12import ProjectM36.Error
13import ProjectM36.RelationalExpression
14import ProjectM36.Key
16--parsers which create "database expressions" which modify the database context (such as relvar assignment)
17databaseExprP :: Parser DatabaseExpr
18databaseExprP = insertP
19 <|> deleteConstraintP
20 <|> deleteP
21 <|> updateP
22 <|> addConstraintP
23 <|> keyP
24 <|> defineP
25 <|> undefineP
26 <|> assignP
28assignP :: Parser DatabaseExpr
29assignP = do
30 relVarName <- try $ do
31 relVarName <- identifier
32 reservedOp ":="
33 return relVarName
34 expr <- relExprP
35 return $ Assign (T.pack relVarName) expr
37multipleDatabaseExprP :: Parser DatabaseExpr
38multipleDatabaseExprP = do
39 exprs <- sepBy1 databaseExprP semi
40 return $ MultipleExpr exprs
42insertP :: Parser DatabaseExpr
43insertP = do
44 reservedOp "insert"
45 relvar <- identifier
46 expr <- relExprP
47 return $ Insert (T.pack relvar) expr
49defineP :: Parser DatabaseExpr
50defineP = do
51 relVarName <- try $ do
52 relVarName <- identifier
53 reservedOp "::"
54 return relVarName
55 attributeSet <- makeAttributesP
56 return $ Define (T.pack relVarName) attributeSet
58undefineP :: Parser DatabaseExpr
59undefineP = do
60 reservedOp "undefine"
61 relVarName <- identifier
62 return $ Undefine (T.pack relVarName)
64deleteP :: Parser DatabaseExpr
65deleteP = do
66 reservedOp "delete"
67 relVarName <- identifier
68 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
69 return $ Delete (T.pack relVarName) predicate
71updateP :: Parser DatabaseExpr
72updateP = do
73 reservedOp "update"
74 relVarName <- identifier
75 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
76 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
77 return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
79addConstraintP :: Parser DatabaseExpr
80addConstraintP = do
81 reservedOp "constraint" <|> reservedOp "foreign key"
82 constraintName <- identifier
83 subset <- relExprP
84 reservedOp "in"
85 superset <- relExprP
86 return $ AddInclusionDependency (T.pack constraintName) (InclusionDependency subset superset)
88deleteConstraintP :: Parser DatabaseExpr
89deleteConstraintP = do
90 reserved "deleteconstraint"
91 constraintName <- identifier
92 return $ RemoveInclusionDependency (T.pack constraintName)
94-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
95keyP :: Parser DatabaseExpr
96keyP = do
97 reserved "key"
98 keyName <- identifier
99 uniquenessAttrNames <- braces attributeListP
100 uniquenessExpr <- relExprP
101 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
102 return $ AddInclusionDependency (T.pack keyName) newIncDep
104attributeAssignmentP :: Parser (String, Atom)
105attributeAssignmentP = do
106 attrName <- identifier
107 reservedOp ":="
108 atom <- stringAtomP <|> intAtomP
109 return $ (attrName, atom)
111databaseExprOpP :: Parser DatabaseExpr
112databaseExprOpP = multipleDatabaseExprP
114evalDatabaseExpr :: Bool -> DatabaseContext -> DatabaseExpr -> Either RelationalError DatabaseContext
115evalDatabaseExpr useOptimizer context expr = do
116 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
117 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
118 (Nothing, context') -> Right context'
119 (Just err, _) -> Left err
122interpretDatabaseExpr :: DatabaseContext -> String -> Either RelationalError DatabaseContext
123interpretDatabaseExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
124 Left err -> Left $ ParseError (T.pack (show err))
125 Right parsed -> evalDatabaseExpr True context parsed
127{-
128--no optimization
129interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
130interpretNO context tutdstring = case parseString tutdstring of
131 Left err -> (Just err, context)
132 Right parsed -> runState (evalContextExpr parsed) context
133-}