git.iko.soy/project-m36
on c0554e0 help sign in
project-m36/TutorialD/Interpreter/DatabaseExpr.hs
167 lines 5.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 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 = 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
33assignP :: Parser DatabaseExpr
34assignP = do
35 relVarName <- try $ do
36 relVarName <- identifier
37 reservedOp ":="
38 return relVarName
39 expr <- relExprP
40 return $ Assign (T.pack relVarName) expr
42multipleDatabaseExprP :: Parser DatabaseExpr
43multipleDatabaseExprP = do
44 exprs <- sepBy1 databaseExprP semi
45 return $ MultipleExpr exprs
47insertP :: Parser DatabaseExpr
48insertP = do
49 reservedOp "insert"
50 relvar <- identifier
51 expr <- relExprP
52 return $ Insert (T.pack relvar) expr
54defineP :: Parser DatabaseExpr
55defineP = do
56 relVarName <- try $ do
57 relVarName <- identifier
58 reservedOp "::"
59 return relVarName
60 attributeSet <- makeAttributeExprsP
61 return $ Define (T.pack relVarName) attributeSet
63undefineP :: Parser DatabaseExpr
64undefineP = do
65 reservedOp "undefine"
66 relVarName <- identifier
67 return $ Undefine (T.pack relVarName)
69deleteP :: Parser DatabaseExpr
70deleteP = do
71 reservedOp "delete"
72 relVarName <- identifier
73 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
74 return $ Delete (T.pack relVarName) predicate
76updateP :: Parser DatabaseExpr
77updateP = do
78 reservedOp "update"
79 relVarName <- identifier
80 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
81 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)
82 return $ Update (T.pack relVarName) (M.mapKeys T.pack $ attributeAssignments) predicate
84addConstraintP :: Parser DatabaseExpr
85addConstraintP = do
86 reservedOp "constraint" <|> reservedOp "foreign key"
87 constraintName <- identifier
88 subset <- relExprP
89 reservedOp "in"
90 superset <- relExprP
91 return $ AddInclusionDependency (T.pack constraintName) (InclusionDependency subset superset)
93deleteConstraintP :: Parser DatabaseExpr
94deleteConstraintP = do
95 reserved "deleteconstraint"
96 constraintName <- identifier
97 return $ RemoveInclusionDependency (T.pack constraintName)
99-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>
100keyP :: Parser DatabaseExpr
101keyP = do
102 reserved "key"
103 keyName <- identifier
104 uniquenessAttrNames <- braces attributeListP
105 uniquenessExpr <- relExprP
106 let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr
107 return $ AddInclusionDependency (T.pack keyName) newIncDep
109attributeAssignmentP :: Parser (String, Atom)
110attributeAssignmentP = do
111 attrName <- identifier
112 reservedOp ":="
113 atom <- stringAtomP <|> intAtomP
114 return $ (attrName, atom)
116addNotificationP :: Parser DatabaseExpr
117addNotificationP = do
118 reserved "notify"
119 notName <- identifier
120 triggerExpr <- relExprP
121 resultExpr <- relExprP
122 return $ AddNotification (T.pack notName) triggerExpr resultExpr
124removeNotificationP :: Parser DatabaseExpr
125removeNotificationP = do
126 reserved "unnotify"
127 notName <- identifier
128 return $ RemoveNotification (T.pack notName)
130-- | data Hair = Bald | Color Text
131addTypeConstructorP :: Parser DatabaseExpr
132addTypeConstructorP = do
133 reserved "data"
134 typeConstructorDef <- typeConstructorDefP
135 reservedOp "="
136 dataConstructorDefs <- sepBy1 dataConstructorDefP pipe
137 pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)
139removeTypeConstructorP :: Parser DatabaseExpr
140removeTypeConstructorP = do
141 reserved "undata"
142 RemoveTypeConstructor <$> liftM T.pack identifier
144databaseExprOpP :: Parser DatabaseExpr
145databaseExprOpP = multipleDatabaseExprP
147evalDatabaseExpr :: Bool -> DatabaseContext -> DatabaseExpr -> Either RelationalError DatabaseContext
148evalDatabaseExpr useOptimizer context expr = do
149 optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) context
150 case runState (evalContextExpr (if useOptimizer then optimizedExpr else expr)) context of
151 (Nothing, context') -> Right context'
152 (Just err, _) -> Left err
155interpretDatabaseExpr :: DatabaseContext -> String -> Either RelationalError DatabaseContext
156interpretDatabaseExpr context tutdstring = case parse databaseExprOpP "" tutdstring of
157 Left err -> Left $ ParseError (T.pack (show err))
158 Right parsed -> evalDatabaseExpr True context parsed
160{-
161--no optimization
162interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
163interpretNO context tutdstring = case parseString tutdstring of
164 Left err -> (Just err, context)
165 Right parsed -> runState (evalContextExpr parsed) context
166-}