git.iko.soy/project-m36
on master help sign in
implement relation variable type safety
b5477e2AgentM
RelationExpr.hs+44−7
compare with master
unifiedsplit
@@ -22,12 +22,19 @@ data RelationalExpr where
22 Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr
22 Project :: S.Set AttributeName -> RelationalExpr -> RelationalExpr
23 Union :: RelationalExpr -> RelationalExpr -> RelationalExpr
23 Union :: RelationalExpr -> RelationalExpr -> RelationalExpr
24 Join :: RelationalExpr -> RelationalExpr -> RelationalExpr
24 Join :: RelationalExpr -> RelationalExpr -> RelationalExpr
25− Assign :: String -> RelationalExpr -> RelationalExpr
26 MultipleExpr :: [RelationalExpr] -> RelationalExpr
25 MultipleExpr :: [RelationalExpr] -> RelationalExpr
27 Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
26 Rename :: AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
28 Group :: S.Set AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
27 Group :: S.Set AttributeName -> AttributeName -> RelationalExpr -> RelationalExpr
29 Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr
28 Ungroup :: AttributeName -> RelationalExpr -> RelationalExpr
30− --Restrict :: RExpr.RestrictionExpr -> 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+
31{- maybe break this into multiple steps:
38{- maybe break this into multiple steps:
321. check relational types for match (attribute counts) (typechecking step
391. check relational types for match (attribute counts) (typechecking step
332. create an execution plan (another system of nodes, another GADT)
402. create an execution plan (another system of nodes, another GADT)
@@ -37,14 +44,38 @@ data RelationalExpr where
37
44
38type RelVarState a = State RelVarContext a
45type RelVarState a = State RelVarContext a
39
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+
40eval :: RelationalExpr -> RelVarState (Either RelationalError Relation)
54eval :: RelationalExpr -> RelVarState (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+
41eval (Assign relVarName expr) = do
65eval (Assign relVarName expr) = do
42− relvarTable <- get
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
43− value <- eval expr
69+ value <- eval expr
44 case value of
70 case value of
45− Right rel -> (put $ M.insert relVarName rel relvarTable) >>
46− (return $ Right rel)
47 Left err -> return $ Left err
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+
48
79
49eval (RelationVariable name) = do
80eval (RelationVariable name) = do
50 relvarTable <- get
81 relvarTable <- get
@@ -102,7 +133,13 @@ eval (Ungroup attrName relExpr) = do
102 case evald of
133 case evald of
103 Right rel -> return $ ungroup attrName rel
134 Right rel -> return $ ungroup attrName rel
104 Left err -> return $ Left err
135 Left err -> return $ Left err
105−
136+
137+eval (Insert relVarName relExpr) = do
138+ evald <- eval $ Assign relVarName (Union relExpr (RelationVariable relVarName))
139+ case evald of
140+ Right rel -> return $ evald
141+ Left err -> return $ Left err
142+
106emptyRelVarContext :: RelVarContext
143emptyRelVarContext :: RelVarContext
107emptyRelVarContext = M.empty
144emptyRelVarContext = M.empty
108
145
RelationalError.hs+2
@@ -10,6 +10,8 @@ data RelationalError = NoSuchAttributeNameError String
10 | AttributeNameInUseError AttributeName
10 | AttributeNameInUseError AttributeName
11 | AttributeIsNotRelationValuedError AttributeName
11 | AttributeIsNotRelationValuedError AttributeName
12 | RelvarNotDefinedError String
12 | RelvarNotDefinedError String
13+ | RelvarAlreadyDefined String
14+ | RelvarAssignmentTypeMismatch
13 | ParseError String
15 | ParseError String
14 deriving (Show,Eq)
16 deriving (Show,Eq)
15
17
TutorialDInterpreter.hs+65−3
@@ -1,4 +1,6 @@
1+{-# LANGUAGE GADTs #-}
1module TutorialDInterpreter where
2module TutorialDInterpreter where
3+import Relation
2import RelationType
4import RelationType
3import RelationalError
5import RelationalError
4import RelationExpr
6import RelationExpr
@@ -11,6 +13,7 @@ import qualified Text.Parsec.Token as Token
11import qualified Data.Set as S
13import qualified Data.Set as S
12import qualified Data.HashSet as HS
14import qualified Data.HashSet as HS
13import qualified Data.Map as M
15import qualified Data.Map as M
16+import qualified Data.List as L
14import Control.Applicative (liftA)
17import Control.Applicative (liftA)
15import Control.Monad.State
18import Control.Monad.State
16import System.Console.Readline
19import System.Console.Readline
@@ -65,11 +68,19 @@ tutDTypeToAtomType tutDType = case tutDType of
65 "int" -> Just IntAtomType
68 "int" -> Just IntAtomType
66 _ -> Nothing
69 _ -> Nothing
67
70
71+atomTypeToTutDType :: AtomType -> Maybe String
72+atomTypeToTutDType atomType = case atomType of
73+ StringAtomType -> Just "char"
74+ IntAtomType -> Just "int"
75+ --RelationAtomType rel ->
76+ _ -> Nothing
77+
68relVarP :: Parser RelationalExpr
78relVarP :: Parser RelationalExpr
69relVarP = liftA RelationVariable identifier
79relVarP = liftA RelationVariable identifier
70
80
71relTerm = parens relExpr
81relTerm = parens relExpr
72 <|> makeRelation
82 <|> makeRelation
83+ <|> (try defineP)
73 <|> relVarP
84 <|> relVarP
74
85
75projectOp = do
86projectOp = do
@@ -111,14 +122,29 @@ ungroupP = do
111 reservedOp "ungroup"
122 reservedOp "ungroup"
112 rvaAttrName <- identifier
123 rvaAttrName <- identifier
113 return $ Ungroup rvaAttrName
124 return $ Ungroup rvaAttrName
114−
125+
115−
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+
116relOperators = [
139relOperators = [
117 [Postfix projectOp],
140 [Postfix projectOp],
118 [Postfix renameP],
141 [Postfix renameP],
119 [Postfix groupP],
142 [Postfix groupP],
143+ [Postfix ungroupP],
120 [Infix (reservedOp "join" >> return Join) AssocLeft],
144 [Infix (reservedOp "join" >> return Join) AssocLeft],
121 [Infix (reservedOp "union" >> return Union) AssocLeft],
145 [Infix (reservedOp "union" >> return Union) AssocLeft],
146+ [Prefix insertP],
147+
122 [Prefix (try assignP)]
148 [Prefix (try assignP)]
123 ]
149 ]
124
150
@@ -134,6 +160,29 @@ parseString :: String -> Either RelationalError RelationalExpr
134parseString str = case parse multipleRelExpr "" str of
160parseString str = case parse multipleRelExpr "" str of
135 Left err -> Left $ ParseError (show err)
161 Left err -> Left $ ParseError (show err)
136 Right r -> Right r
162 Right r -> Right r
163+
164+data TutorialDOperator where
165+ ShowRelationVariableType :: String -> TutorialDOperator
166+
167+interpreterOps :: Parser TutorialDOperator
168+interpreterOps = do
169+ reservedOp ":t"
170+ relVarName <- identifier
171+ return $ ShowRelationVariableType relVarName
172+
173+showRelationAttributes :: Relation -> String
174+showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
175+ where
176+ showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
177+ Just t -> show t
178+ Nothing -> "unknown"
179+ attrs = values (attributes rel)
180+ values m = map snd (M.toAscList m)
181+
182+evalTutorialDOp :: RelVarContext -> TutorialDOperator -> String
183+evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName context of
184+ Just rel -> showRelationAttributes rel
185+ Nothing -> relVarName ++ " not defined"
137
186
138example1 = "relA {a,b, c}"
187example1 = "relA {a,b, c}"
139example2 = "relA join relB"
188example2 = "relA join relB"
@@ -149,7 +198,13 @@ interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVar
149interpret context tutdstring = case parseString tutdstring of
198interpret context tutdstring = case parseString tutdstring of
150 Left err -> (Left err, context)
199 Left err -> (Left err, context)
151 Right parsed -> runState (eval parsed) context
200 Right parsed -> runState (eval parsed) context
152−
201+
202+-- for interpreter-specific operations
203+interpretOps :: RelVarContext -> String -> Maybe String
204+interpretOps context instring = case parse interpreterOps "" instring of
205+ Left err -> Nothing
206+ Right ops -> Just $ evalTutorialDOp context ops
207+
153reprLoop :: RelVarContext -> IO ()
208reprLoop :: RelVarContext -> IO ()
154reprLoop context = do
209reprLoop context = do
155 maybeLine <- readline "TutorialD: "
210 maybeLine <- readline "TutorialD: "
@@ -157,6 +212,13 @@ reprLoop context = do
157 Nothing -> return ()
212 Nothing -> return ()
158 Just line -> do
213 Just line -> do
159 addHistory line
214 addHistory line
215+
216+ case interpretOps context line of
217+ Just out -> do
218+ putStrLn out
219+ reprLoop context
220+ Nothing -> return ()
221+
160 let (value, contextup) = interpret context line
222 let (value, contextup) = interpret context line
161 case value of
223 case value of
162 (Right rel) -> do
224 (Right rel) -> do