git.iko.soy/project-m36
on master help sign in
refactoring to add more expression types
2e1e4d2AgentM
DatabaseContext.hsnew file
compare with master
unifiedsplit

No changes to the content.

Relation.hs+1−1
@@ -243,7 +243,7 @@ imageRelationFor matchTuple rel@(Relation attrs _) = do
243imageRelationTest = imageRelationFor tup s
243imageRelationTest = imageRelationFor tup s
244 where
244 where
245 tup = mkRelationTuple (S.fromList ["SNAME", "CITY", "S#"]) (M.fromList [("SNAME", StringAtom "Smith"), ("S#", StringAtom "S1"), ("CITY", StringAtom "London")])
245 tup = mkRelationTuple (S.fromList ["SNAME", "CITY", "S#"]) (M.fromList [("SNAME", StringAtom "Smith"), ("S#", StringAtom "S1"), ("CITY", StringAtom "London")])
246−
246+
247--returns a relation-valued attribute image relation for each tuple in rel1
247--returns a relation-valued attribute image relation for each tuple in rel1
248--algorithm:
248--algorithm:
249 {-
249 {-
RelationExpr.hs+88−108
@@ -1,154 +1,80 @@
1−{-# LANGUAGE GADTs #-}
2module RelationExpr where
1module RelationExpr where
3import Relation
2import Relation
4import RelationTuple
3import RelationTuple
4+import RelationTupleSet
5import RelationType
5import RelationType
6import RelationalError
6import RelationalError
7−import qualified Data.Set as S
8import qualified Data.Map as M
7import qualified Data.Map as M
9import qualified Data.HashSet as HS
8import qualified Data.HashSet as HS
10import Control.Monad.State hiding (join)
9import Control.Monad.State hiding (join)
11
10
12−type RelVarContext = M.Map String Relation
11+--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values
13−
14−type AtomName = String
15−
16−data RelationalExpr where
17− MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr
18− --MakeFunctionalRelation (creates a relation from a tuple-generating function, potentially infinite)
19− --in Tutorial D, relational variables pick up the type of the first relation assigned to them
20− --relational variables should also be able to be explicitly-typed like in Haskell
21− RelationVariable :: String -> RelationalExpr
22− Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr
23− Union :: RelationalExpr -> RelationalExpr -> RelationalExpr
24− Join :: RelationalExpr -> RelationalExpr -> RelationalExpr
25− MultipleExpr :: [RelationalExpr] -> RelationalExpr
26− Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
27− Group :: S.Set AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
28− Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr
29− --Restrict :: RExpr.RestrictionExpr -> RelationalExpr -> RelationalExpr
30−
31− --nominal relational expressions- the following operations could also be deemed non-relational, but I allow them to return relational expressions regardless- maybe this doesn't make sense since they should only be allowed as top-level commands
32− Define :: String -> Attributes -> RelationalExpr
33− Assign :: String -> RelationalExpr -> RelationalExpr
34− Insert :: String -> RelationalExpr -> RelationalExpr
35− Delete :: String -> RelationalExpr -- needs restriction support
36− Update :: String -> M.Map String Atom -> RelationalExpr -- needs restriction support
37−
38−{- maybe break this into multiple steps:
39−1. check relational types for match (attribute counts) (typechecking step
40−2. create an execution plan (another system of nodes, another GADT)
41−3. execute the plan
42−-}
43− deriving (Show)
44−
45−type RelVarState a = State RelVarContext a
46−
47−--helper function to process relation variable creation/assignment
48−setRelVar :: String -> Relation -> RelVarState (Either RelationalError Relation)
49−setRelVar relVarName rel = do
50− relVars <- get
51− put $ M.insert relVarName rel relVars
52− return $ Right rel
53−
54−eval :: RelationalExpr -> RelVarState (Either RelationalError Relation)
12+evalRelationalExpr :: RelationalExpr -> DatabaseState (Either RelationalError Relation)
55−
56−--define a relvar by creating an empty-tupled relation
57−eval (Define relVarName attributes) = do
58− relvars <- get
59− case M.member relVarName relvars of
60− True -> return (Left (RelvarAlreadyDefined relVarName))
61− False -> setRelVar relVarName emptyRelation
62− where
63− emptyRelation = Relation attributes HS.empty
64−
65−eval (Assign relVarName expr) = do
66− relVarTable <- get
67− -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
68− let existingRelVar = M.lookup relVarName relVarTable
69− value <- eval expr
70− case value of
71− Left err -> return $ Left err
72− Right rel -> case existingRelVar of
73− Nothing -> setRelVar relVarName rel
74− Just existingRel -> if attributes existingRel == attributes rel then
75− setRelVar relVarName rel
76− else
77− return $ Left RelvarAssignmentTypeMismatch
78−
79−
80−eval (RelationVariable name) = do
13+evalRelationalExpr (RelationVariable name) = do
81− relvarTable <- get
14+ relvarTable <- liftM relationVariables get
82 return $ case M.lookup name relvarTable of
15 return $ case M.lookup name relvarTable of
83 Just res -> Right res
16 Just res -> Right res
84− Nothing -> Left $ RelvarNotDefinedError name
17+ Nothing -> Left $ RelVarNotDefinedError name
85
18
86−eval (Project attrNameSet expr) = do
19+evalRelationalExpr (Project attrNameSet expr) = do
87− rel <- eval expr
20+ rel <- evalRelationalExpr expr
88 case rel of
21 case rel of
89 Right rel -> return $ project attrNameSet rel
22 Right rel -> return $ project attrNameSet rel
90 Left err -> return $ Left err
23 Left err -> return $ Left err
91
24
92−eval (Union exprA exprB) = do
25+evalRelationalExpr (Union exprA exprB) = do
93− relA <- eval exprA
26+ relA <- evalRelationalExpr exprA
94− relB <- eval exprB
27+ relB <- evalRelationalExpr exprB
95 case relA of
28 case relA of
96 Left err -> return $ Left err
29 Left err -> return $ Left err
97 Right relA -> case relB of
30 Right relA -> case relB of
98 Left err -> return $ Left err
31 Left err -> return $ Left err
99 Right relB -> return $ union relA relB
32 Right relB -> return $ union relA relB
100
33
101−eval (Join exprA exprB) = do
34+evalRelationalExpr (Join exprA exprB) = do
102− relA <- eval exprA
35+ relA <- evalRelationalExpr exprA
103− relB <- eval exprB
36+ relB <- evalRelationalExpr exprB
104 case relA of
37 case relA of
105 Left err -> return $ Left err
38 Left err -> return $ Left err
106 Right relA -> case relB of
39 Right relA -> case relB of
107 Left err -> return $ Left err
40 Left err -> return $ Left err
108 Right relB -> return $ join relA relB
41 Right relB -> return $ join relA relB
109
42
110−eval (MultipleExpr exprs) = do
111− evald <- mapM eval exprs
112− return $ last evald
113−
114−eval (MakeStaticRelation attributes tupleSet) = do
43+evalRelationalExpr (MakeStaticRelation attributes tupleSet) = do
115 case mkRelation attributes tupleSet of
44 case mkRelation attributes tupleSet of
116 Right rel -> return $ Right rel
45 Right rel -> return $ Right rel
117 Left err -> return $ Left err
46 Left err -> return $ Left err
118
47
119−eval (Rename oldAttrName newAttrName relExpr) = do
48+evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do
120− evald <- eval relExpr
49+ evald <- evalRelationalExpr relExpr
121 case evald of
50 case evald of
122 Right rel -> return $ rename oldAttrName newAttrName rel
51 Right rel -> return $ rename oldAttrName newAttrName rel
123 Left err -> return $ Left err
52 Left err -> return $ Left err
124
53
125−eval (Group oldAttrNameSet newAttrName relExpr) = do
54+evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do
126− evald <- eval relExpr
55+ evald <- evalRelationalExpr relExpr
127 case evald of
56 case evald of
128 Right rel -> return $ group oldAttrNameSet newAttrName rel
57 Right rel -> return $ group oldAttrNameSet newAttrName rel
129 Left err -> return $ Left err
58 Left err -> return $ Left err
130
59
131−eval (Ungroup attrName relExpr) = do
60+evalRelationalExpr (Ungroup attrName relExpr) = do
132− evald <- eval relExpr
61+ evald <- evalRelationalExpr relExpr
133 case evald of
62 case evald of
134 Right rel -> return $ ungroup attrName rel
63 Right rel -> return $ ungroup attrName rel
135 Left err -> return $ Left err
64 Left err -> return $ Left err
136−
65+
137−eval (Insert relVarName relExpr) = do
66+emptyDatabaseContext :: DatabaseContext
138− evald <- eval $ Assign relVarName (Union relExpr (RelationVariable relVarName))
67+emptyDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,
139− case evald of
68+ relationVariables = M.empty}
140− Right rel -> return $ evald
69+
141− Left err -> return $ Left err
70+basicDatabaseContext :: DatabaseContext
142−
71+basicDatabaseContext = DatabaseContext { inclusionDependencies = HS.empty,
143−emptyRelVarContext :: RelVarContext
144−emptyRelVarContext = M.empty
145−
146−basicRelVarContext :: RelVarContext
147−basicRelVarContext = M.fromList [("true", relationTrue),
72+ relationVariables = M.fromList [("true", relationTrue),
148− ("false", relationFalse)]
73+ ("false", relationFalse)]}
149−
74+
150−dateExamples :: RelVarContext
75+dateExamples :: DatabaseContext
151−dateExamples = M.union basicRelVarContext dateRelVars
76+dateExamples = DatabaseContext { inclusionDependencies = HS.empty, -- add foreign key relationships
77+ relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars }
152 where
78 where
153 dateRelVars = M.fromList [("S", suppliers),
79 dateRelVars = M.fromList [("S", suppliers),
154 ("P", products),
80 ("P", products),
@@ -212,3 +138,57 @@ supplierProductsRel = case mkRelation attributes tupleSet of
212 M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P4"), ("QTY", IntAtom 300)],
138 M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P4"), ("QTY", IntAtom 300)],
213 M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P5"), ("QTY", IntAtom 400)]
139 M.fromList [("S#", StringAtom "S4"), ("P#", StringAtom "P5"), ("QTY", IntAtom 400)]
214 ]
140 ]
141+
142+--helper function to process relation variable creation/assignment
143+setRelVar :: String -> Relation -> DatabaseState (Maybe RelationalError)
144+setRelVar relVarName rel = do
145+ state <- get
146+ let newRelVars = M.insert relVarName rel $ relationVariables state
147+ put $ DatabaseContext (inclusionDependencies state) newRelVars
148+ return Nothing
149+
150+evalContextExpr :: DatabaseExpr -> DatabaseState (Maybe RelationalError)
151+evalContextExpr (Define relVarName attrs) = do
152+ relvars <- liftM relationVariables get
153+ case M.member relVarName relvars of
154+ True -> return (Just (RelVarAlreadyDefinedError relVarName))
155+ False -> setRelVar relVarName emptyRelation
156+ where
157+ emptyRelation = Relation attrs HS.empty
158+
159+evalContextExpr (Assign relVarName expr) = do
160+ -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it
161+ relVarTable <- liftM relationVariables get
162+ let existingRelVar = M.lookup relVarName relVarTable
163+ value <- evalRelationalExpr expr
164+ case value of
165+ Left err -> return $ Just err
166+ Right rel -> case existingRelVar of
167+ Nothing -> setRelVar relVarName rel
168+ Just existingRel -> if attributes existingRel == attributes rel then
169+ setRelVar relVarName rel
170+ else
171+ return $ Just RelVarAssignmentTypeMismatchError
172+
173+evalContextExpr (Insert relVarName relExpr) = evalContextExpr $ Assign relVarName (Union relExpr (RelationVariable relVarName))
174+
175+--assign empty rel until restriction is implemented
176+evalContextExpr (Delete relVarName) = do
177+ relVarTable <- liftM relationVariables get
178+ case M.lookup relVarName relVarTable of
179+ Nothing -> return $ Just (RelVarNotDefinedError relVarName)
180+ Just rel -> setRelVar relVarName (Relation (attributes rel) emptyTupleSet)
181+
182+evalContextExpr (Update relVarName attrAssignments) = undefined
183+
184+evalContextExpr (AddInclusionDependency dep) = undefined
185+
186+evalContextExpr (MultipleExpr exprs) = do
187+ evald <- mapM evalContextExpr exprs
188+ return $ last evald
189+
190+-- restrict relvar to get affected tuples, update tuples, delete restriction from relvar, relvar = relvar union updated tuples
191+--evalRelVarExpr (Update relVarName updateMap) = do
192+
193+
194+
RelationType.hs+47
@@ -1,7 +1,10 @@
1+{-# LANGUAGE GADTs #-}
1module RelationType where
2module RelationType where
2import qualified Data.Map as M
3import qualified Data.Map as M
3import qualified Data.HashSet as HS
4import qualified Data.HashSet as HS
4import qualified Data.Hashable as Hash
5import qualified Data.Hashable as Hash
6+import qualified Data.Set as S
7+import Control.Monad.State hiding (join)
5
8
6data Atom = StringAtom String |
9data Atom = StringAtom String |
7 IntAtom Int |
10 IntAtom Int |
@@ -12,6 +15,8 @@ data AtomType = StringAtomType |
12 RelationAtomType Attributes deriving (Eq, Show)
15 RelationAtomType Attributes deriving (Eq, Show)
13
16
14type AttributeName = String
17type AttributeName = String
18+type AtomName = String
19+
15data Attribute = Attribute AttributeName AtomType deriving (Eq, Show)
20data Attribute = Attribute AttributeName AtomType deriving (Eq, Show)
16
21
17type Attributes = M.Map AttributeName Attribute --attributes keys by attribute name for ease of access
22type Attributes = M.Map AttributeName Attribute --attributes keys by attribute name for ease of access
@@ -27,4 +32,46 @@ data Relation = Relation Attributes RelationTupleSet deriving (Show, Eq)
27data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show)
32data RelationCardinality = Uncountable | Countable Int deriving (Eq, Show)
28data RelationSizeInfinite = RelationSizeInfinite
33data RelationSizeInfinite = RelationSizeInfinite
29
34
35+data RelationalExpr where
36+ MakeStaticRelation :: Attributes -> RelationTupleSet -> RelationalExpr
37+ --MakeFunctionalRelation (creates a relation from a tuple-generating function, potentially infinite)
38+ --in Tutorial D, relational variables pick up the type of the first relation assigned to them
39+ --relational variables should also be able to be explicitly-typed like in Haskell
40+ RelationVariable :: String -> RelationalExpr
41+ Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr
42+ Union :: RelationalExpr -> RelationalExpr -> RelationalExpr
43+ Join :: RelationalExpr -> RelationalExpr -> RelationalExpr
44+ Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
45+ Group :: S.Set AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
46+ Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr
47+ --Restrict :: RExpr.RestrictionExpr -> RelationalExpr -> RelationalExpr
48+
49+{- maybe break this into multiple steps:
50+1. check relational types for match (attribute counts) (typechecking step
51+2. create an execution plan (another system of nodes, another GADT)
52+3. execute the plan
53+-}
54+ deriving (Show)
55+
56+data DatabaseContext = DatabaseContext {
57+ inclusionDependencies :: HS.HashSet InclusionDependency,
58+ relationVariables :: M.Map String Relation
59+ } deriving (Show)
60+
61+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show)
62+
63+instance Hash.Hashable InclusionDependency where
64+ hashWithSalt salt dep = Hash.hashWithSalt salt (show dep)
65+
66+--Database context expressions modify the database context while relational expressions do not
67+data DatabaseExpr where
68+ Define :: String -> Attributes -> DatabaseExpr
69+ Assign :: String -> RelationalExpr -> DatabaseExpr
70+ Insert :: String -> RelationalExpr -> DatabaseExpr
71+ Delete :: String -> DatabaseExpr -- needs restriction support
72+ Update :: String -> M.Map String RelationalExpr -> DatabaseExpr -- needs restriction support
73+ AddInclusionDependency :: InclusionDependency -> DatabaseExpr
74+ MultipleExpr :: [DatabaseExpr] -> DatabaseExpr
75+ deriving (Show)
30
76
77+type DatabaseState a = State DatabaseContext a
RelationalError.hs+3−5
@@ -1,5 +1,4 @@
1module RelationalError where
1module RelationalError where
2−import qualified Control.Monad.Error as Err
3import RelationType
2import RelationType
4
3
5data RelationalError = NoSuchAttributeNameError String
4data RelationalError = NoSuchAttributeNameError String
@@ -9,11 +8,10 @@ data RelationalError = NoSuchAttributeNameError String
9 | AttributeNameMismatchError String
8 | AttributeNameMismatchError String
10 | AttributeNameInUseError AttributeName
9 | AttributeNameInUseError AttributeName
11 | AttributeIsNotRelationValuedError AttributeName
10 | AttributeIsNotRelationValuedError AttributeName
12− | RelvarNotDefinedError String
11+ | RelVarNotDefinedError String
13− | RelvarAlreadyDefined String
12+ | RelVarAlreadyDefinedError String
14− | RelvarAssignmentTypeMismatch
13+ | RelVarAssignmentTypeMismatchError
15 | ParseError String
14 | ParseError String
16 deriving (Show,Eq)
15 deriving (Show,Eq)
17
16
18−instance Err.Error RelationalError where
19
17
RelationalInclusionDependency.hsnew file+10
@@ -0,0 +1,10 @@
1+module RelationalInclusionDependency where
2+import RelationalError
3+
4+--run verification on all constraints
5+checkConstraints :: DatabaseContext -> Maybe RelationalError
6+checkConstraints context = undefined
7+
8+checkConstraint :: DatabaseContext -> Constraint -> Maybe RelationalError
9+checkConstraint context constraint = undefined
10+
TutorialDInterpreter.hs+81−39
@@ -14,7 +14,7 @@ import qualified Data.Set as S
14import qualified Data.HashSet as HS
14import qualified Data.HashSet as HS
15import qualified Data.Map as M
15import qualified Data.Map as M
16import qualified Data.List as L
16import qualified Data.List as L
17−import Control.Applicative (liftA)
17+import Control.Applicative (liftA, (<*))
18import Control.Monad.State
18import Control.Monad.State
19import System.Console.Readline
19import System.Console.Readline
20
20
@@ -80,17 +80,18 @@ relVarP = liftA RelationVariable identifier
80
80
81relTerm = parens relExpr
81relTerm = parens relExpr
82 <|> makeRelation
82 <|> makeRelation
83− <|> (try defineP)
84 <|> relVarP
83 <|> relVarP
85
84
86projectOp = do
85projectOp = do
87 attrs <- braces attributeList
86 attrs <- braces attributeList
88 return $ Project (S.fromList attrs)
87 return $ Project (S.fromList attrs)
89
88
89+assignP :: Parser DatabaseExpr
90assignP = do
90assignP = do
91 relVarName <- identifier
91 relVarName <- identifier
92 reservedOp ":="
92 reservedOp ":="
93+ expr <- relExpr
93− return $ Assign relVarName
94+ return $ Assign relVarName expr
94
95
95renameClause = do
96renameClause = do
96 oldAttr <- identifier
97 oldAttr <- identifier
@@ -123,52 +124,90 @@ ungroupP = do
123 rvaAttrName <- identifier
124 rvaAttrName <- identifier
124 return $ Ungroup rvaAttrName
125 return $ Ungroup rvaAttrName
125
126
126−insertP :: Parser (RelationalExpr -> RelationalExpr)
127−insertP = do
128− reservedOp "insert"
129− relvar <- identifier
130− return $ Insert relvar
131−
132−defineP :: Parser RelationalExpr
133−defineP = do
134− relVarName <- identifier
135− reservedOp "::"
136− attributes <- makeAttributes
137− return $ Define relVarName attributes
138−
139relOperators = [
127relOperators = [
140 [Postfix projectOp],
128 [Postfix projectOp],
141 [Postfix renameP],
129 [Postfix renameP],
142 [Postfix groupP],
130 [Postfix groupP],
143 [Postfix ungroupP],
131 [Postfix ungroupP],
144 [Infix (reservedOp "join" >> return Join) AssocLeft],
132 [Infix (reservedOp "join" >> return Join) AssocLeft],
145− [Infix (reservedOp "union" >> return Union) AssocLeft],
133+ [Infix (reservedOp "union" >> return Union) AssocLeft]
146− [Prefix insertP],
147−
148− [Prefix (try assignP)]
149 ]
134 ]
150
135
151relExpr :: Parser RelationalExpr
136relExpr :: Parser RelationalExpr
152relExpr = buildExpressionParser relOperators relTerm
137relExpr = buildExpressionParser relOperators relTerm
153
138
154−multipleRelExpr :: Parser RelationalExpr
139+databaseExpr :: Parser DatabaseExpr
155−multipleRelExpr = do
140+databaseExpr = insertP
141+ <|> deleteP
142+ <|> updateP
143+ <|> try defineP
144+ <|> try assignP
145+
146+multipleDatabaseExpr :: Parser DatabaseExpr
147+multipleDatabaseExpr = do
156− exprs <- sepBy1 relExpr semi
148+ exprs <- sepBy1 databaseExpr semi
157− return $ MultipleExpr exprs
149+ return $ MultipleExpr exprs
150+
151+insertP :: Parser DatabaseExpr
152+insertP = do
153+ reservedOp "insert"
154+ relvar <- identifier
155+ expr <- relExpr
156+ return $ Insert relvar expr
157+
158+defineP :: Parser DatabaseExpr
159+defineP = do
160+ relVarName <- identifier
161+ reservedOp "::"
162+ attributes <- makeAttributes
163+ return $ Define relVarName attributes
164+
165+deleteP :: Parser DatabaseExpr
166+deleteP = do
167+ reservedOp "delete"
168+ relVarName <- identifier
169+ return $ Delete relVarName
170+
171+updateP :: Parser DatabaseExpr
172+updateP = do
173+ reservedOp "update"
174+ relVarName <- identifier
175+ -- where clause
176+ attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
177+ return $ Update relVarName attributeAssignments
158
178
179+attributeAssignment :: Parser (String, RelationalExpr)
180+attributeAssignment = do
181+ attrName <- identifier
182+ reservedOp ":="
183+ relExpr <- relExpr
184+ return $ (attrName, relExpr)
185+
159−parseString :: String -> Either RelationalError RelationalExpr
186+parseString :: String -> Either RelationalError DatabaseExpr
160−parseString str = case parse multipleRelExpr "" str of
187+parseString str = case parse multipleDatabaseExpr "" str of
161 Left err -> Left $ ParseError (show err)
188 Left err -> Left $ ParseError (show err)
162 Right r -> Right r
189 Right r -> Right r
163
190
164data TutorialDOperator where
191data TutorialDOperator where
192+ ShowRelation :: RelationalExpr -> TutorialDOperator
165 ShowRelationVariableType :: String -> TutorialDOperator
193 ShowRelationVariableType :: String -> TutorialDOperator
194+ deriving (Show)
166
195
167−interpreterOps :: Parser TutorialDOperator
196+typeP :: Parser TutorialDOperator
168−interpreterOps = do
197+typeP = do
169 reservedOp ":t"
198 reservedOp ":t"
170 relVarName <- identifier
199 relVarName <- identifier
171 return $ ShowRelationVariableType relVarName
200 return $ ShowRelationVariableType relVarName
201+
202+showP :: Parser TutorialDOperator
203+showP = do
204+ reservedOp ":s"
205+ expr <- relExpr
206+ return $ ShowRelation expr
207+
208+interpreterOps :: Parser TutorialDOperator
209+interpreterOps = typeP
210+ <|> showP
172
211
173showRelationAttributes :: Relation -> String
212showRelationAttributes :: Relation -> String
174showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
213showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
@@ -179,11 +218,16 @@ showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribu
179 attrs = values (attributes rel)
218 attrs = values (attributes rel)
180 values m = map snd (M.toAscList m)
219 values m = map snd (M.toAscList m)
181
220
182−evalTutorialDOp :: RelVarContext -> TutorialDOperator -> String
221+evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String
183−evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName context of
222+evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName (relationVariables context) of
184 Just rel -> showRelationAttributes rel
223 Just rel -> showRelationAttributes rel
185 Nothing -> relVarName ++ " not defined"
224 Nothing -> relVarName ++ " not defined"
186
225
226+evalTutorialDOp context (ShowRelation expr) = do
227+ case runState (evalRelationalExpr expr) context of
228+ (Left err, _) -> show err
229+ (Right rel, _) -> showRelation rel
230+
187example1 = "relA {a,b, c}"
231example1 = "relA {a,b, c}"
188example2 = "relA join relB"
232example2 = "relA join relB"
189example3 = "relA join relB {x,y,z}"
233example3 = "relA join relB {x,y,z}"
@@ -194,18 +238,18 @@ example7 = "rv1 := relA union relB"
194example8 = "relA := true; relB := false"
238example8 = "relA := true; relB := false"
195example9 = "relA := relation { SNO CHAR }"
239example9 = "relA := relation { SNO CHAR }"
196
240
197−interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)
241+interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
198interpret context tutdstring = case parseString tutdstring of
242interpret context tutdstring = case parseString tutdstring of
199− Left err -> (Left err, context)
243+ Left err -> (Just err, context)
200− Right parsed -> runState (eval parsed) context
244+ Right parsed -> runState (evalContextExpr parsed) context
201
245
202-- for interpreter-specific operations
246-- for interpreter-specific operations
203−interpretOps :: RelVarContext -> String -> Maybe String
247+interpretOps :: DatabaseContext -> String -> Maybe String
204interpretOps context instring = case parse interpreterOps "" instring of
248interpretOps context instring = case parse interpreterOps "" instring of
205 Left err -> Nothing
249 Left err -> Nothing
206 Right ops -> Just $ evalTutorialDOp context ops
250 Right ops -> Just $ evalTutorialDOp context ops
207
251
208−reprLoop :: RelVarContext -> IO ()
252+reprLoop :: DatabaseContext -> IO ()
209reprLoop context = do
253reprLoop context = do
210 maybeLine <- readline "TutorialD: "
254 maybeLine <- readline "TutorialD: "
211 case maybeLine of
255 case maybeLine of
@@ -221,10 +265,8 @@ reprLoop context = do
221
265
222 let (value, contextup) = interpret context line
266 let (value, contextup) = interpret context line
223 case value of
267 case value of
224− (Right rel) -> do
225− putStrLn $ showRelation rel
226− reprLoop contextup
268+ Nothing -> reprLoop contextup
227− (Left err) -> do
269+ (Just err) -> do
228 putStrLn $ show err
270 putStrLn $ show err
229 reprLoop context
271 reprLoop context
230
272
TutorialDInterpreterTest.hs+13−11
@@ -11,22 +11,24 @@ main = do
11 counts <- runTestTT (TestList tests)
11 counts <- runTestTT (TestList tests)
12 if errors counts + failures counts > 0 then exitFailure else exitSuccess
12 if errors counts + failures counts > 0 then exitFailure else exitSuccess
13 where
13 where
14− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicRelVarContext tutd expected) simpleRelTests
14+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext tutd expected) simpleRelTests
15− simpleRelTests = [("true", Right relationTrue),
15+ simpleRelTests = [("x:=true", Right relationTrue),
16− ("false", Right relationFalse),
16+ ("x:=false", Right relationFalse),
17− ("true union false", Right relationTrue),
17+ ("x:=true union false", Right relationTrue),
18− ("true; false", Right relationFalse),
18+ ("x:=true; x:=false", Right relationFalse),
19− ("a:=relation{a int}", mkRelation simpleAAttributes HS.empty),
19+ ("x:=relation{a int}", mkRelation simpleAAttributes HS.empty),
20− ("b:=relation{c int} rename {c as d}", mkRelation simpleBAttributes HS.empty),
20+ ("x:=relation{c int} rename {c as d}", mkRelation simpleBAttributes HS.empty),
21− ("a:=relation{b int, c int}; a{c}", mkRelation simpleProjectionAttributes HS.empty)
21+ ("y:=relation{b int, c int}; x:=y{c}", mkRelation simpleProjectionAttributes HS.empty)
22 ]
22 ]
23 simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]
23 simpleAAttributes = M.fromList [("a", Attribute "a" IntAtomType)]
24 simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]
24 simpleBAttributes = M.fromList [("d", Attribute "d" IntAtomType)]
25 simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]
25 simpleProjectionAttributes = M.fromList [("c", Attribute "c" IntAtomType)]
26
26
27
27
28−testSimple1 = TestCase $ assertTutdEqual basicRelVarContext "true" (Right relationTrue)
28+testSimple1 = TestCase $ assertTutdEqual basicDatabaseContext "true" (Right relationTrue)
29
29
30−assertTutdEqual relVarContext tutd expected = assertEqual tutd interpreted expected
30+assertTutdEqual databaseContext tutd expected = assertEqual tutd interpreted expected
31 where
31 where
32− interpreted = fst (interpret relVarContext tutd)
32+ interpreted = case interpret databaseContext tutd of
33+ (Just err, _) -> Left err
34+ (Nothing, context) -> Right $ (relationVariables context) M.! "x"