git.iko.soy/project-m36
on f95e64c help sign in
project-m36/TutorialDInterpreter.hs
377 lines 12 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialDInterpreter where
3import Relation
4import RelationType
5import RelationalError
6import RelationExpr
7import RelationTerm
8import Text.Parsec
9import Text.Parsec.String
10import Text.Parsec.Expr
11import Text.Parsec.Language
12import qualified Text.Parsec.Token as Token
13import qualified Data.Set as S
14import qualified Data.HashSet as HS
15import qualified Data.Map as M
16import qualified Data.List as L
17import Control.Applicative (liftA, (<*), (*>))
18import Control.Monad.State
19import System.Console.Readline
20import System.IO
22lexer :: Token.TokenParser ()
23lexer = Token.makeTokenParser tutD
24 where tutD = emptyDef {
25 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
26 Token.reservedNames = [],
27 Token.identStart = letter <|> char '_',
28 Token.identLetter = alphaNum <|> char '_'}
30parens = Token.parens lexer
31reservedOp = Token.reservedOp lexer
32reserved = Token.reserved lexer
33braces = Token.braces lexer
34identifier = Token.identifier lexer
35comma = Token.comma lexer
36semi = Token.semi lexer
38--used in projection
39attributeList :: Parser [AttributeName]
40attributeList = sepBy identifier comma
42makeRelation :: Parser RelationalExpr
43makeRelation = do
44 reservedOp "relation"
45 attrs <- makeAttributes
46 return $ MakeStaticRelation attrs HS.empty
48--used in relation creation
49makeAttributes :: Parser Attributes
50makeAttributes = do
51 attrList <- braces (sepBy attributeAndType comma)
52 return $ M.fromList $ map toAttributeAssocList attrList
53 where
54 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
56attributeAndType :: Parser Attribute
57attributeAndType = do
58 attrName <- identifier
59 attrTypeName <- identifier
60 --convert type name into type
61 case tutDTypeToAtomType attrTypeName of
62 Just t -> return $ Attribute attrName t
63 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
65tupleP :: Parser RelationTuple
66tupleP = do
67 reservedOp "tuple"
68 attrValues <- braces (sepBy tupleAtomP comma)
69 return $ RelationTuple (M.fromList attrValues)
71tupleAtomP :: Parser (AttributeName, Atom)
72tupleAtomP = do
73 attributeName <- identifier
74 attrType <- identifier
75 atom <- parens (stringAtomP <|> intAtomP)
76 case tutDTypeToAtomType attrType of
77 Nothing -> fail (attrType ++ " is not a valid type name.")
78 Just typeA -> if typeA == atomTypeForAtom atom then
79 return $ (attributeName, atom)
80 else
81 fail "type mismatch in tuple generation"
83--convert Tutorial D type to AtomType
84tutDTypeToAtomType :: String -> Maybe AtomType
85tutDTypeToAtomType tutDType = case tutDType of
86 "char" -> Just StringAtomType
87 "int" -> Just IntAtomType
88 _ -> Nothing
90atomTypeToTutDType :: AtomType -> Maybe String
91atomTypeToTutDType atomType = case atomType of
92 StringAtomType -> Just "char"
93 IntAtomType -> Just "int"
94 --RelationAtomType rel ->
95 _ -> Nothing
97relVarP :: Parser RelationalExpr
98relVarP = liftA RelationVariable identifier
100relTerm = parens relExpr
101 <|> makeRelation
102 <|> relVarP
104projectOp = do
105 attrs <- braces attributeList
106 return $ Project (S.fromList attrs)
108assignP :: Parser DatabaseExpr
109assignP = do
110 relVarName <- try $ do
111 relVarName <- identifier
112 reservedOp ":="
113 return relVarName
114 expr <- relExpr
115 return $ Assign relVarName expr
117renameClause = do
118 oldAttr <- identifier
119 reservedOp "as"
120 newAttr <- identifier
121 return $ (oldAttr, newAttr)
123renameP :: Parser (RelationalExpr -> RelationalExpr)
124renameP = do
125 reservedOp "rename"
126 (oldAttr, newAttr) <- braces renameClause
127 return $ Rename oldAttr newAttr
129whereClauseP = do
130 reservedOp "where"
131 boolExpr <- restrictionPredicateP
132 return $ Restrict boolExpr
134groupClause = do
135 attrs <- braces attributeList
136 reservedOp "as"
137 newAttrName <- identifier
138 return $ (attrs, newAttrName)
140groupP :: Parser (RelationalExpr -> RelationalExpr)
141groupP = do
142 reservedOp "group"
143 (groupAttrList, groupAttrName) <- parens groupClause
144 return $ Group (S.fromList groupAttrList) groupAttrName
146--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.
147ungroupP :: Parser (RelationalExpr -> RelationalExpr)
148ungroupP = do
149 reservedOp "ungroup"
150 rvaAttrName <- identifier
151 return $ Ungroup rvaAttrName
153relOperators = [
154 [Postfix projectOp],
155 [Postfix renameP],
156 [Postfix whereClauseP],
157 [Postfix groupP],
158 [Postfix ungroupP],
159 [Infix (reservedOp "join" >> return Join) AssocLeft],
160 [Infix (reservedOp "union" >> return Union) AssocLeft],
161 [Infix (reservedOp "=" >> return Equals) AssocNone]
162 ]
164relExpr :: Parser RelationalExpr
165relExpr = buildExpressionParser relOperators relTerm
167databaseExpr :: Parser DatabaseExpr
168databaseExpr = insertP
169 <|> deleteP
170 <|> updateP
171 <|> constraintP
172 <|> defineP
173 <|> assignP
175multipleDatabaseExpr :: Parser DatabaseExpr
176multipleDatabaseExpr = do
177 exprs <- sepBy1 databaseExpr semi
178 return $ MultipleExpr exprs
180insertP :: Parser DatabaseExpr
181insertP = do
182 reservedOp "insert"
183 relvar <- identifier
184 expr <- relExpr
185 return $ Insert relvar expr
187defineP :: Parser DatabaseExpr
188defineP = do
189 relVarName <- try $ do
190 relVarName <- identifier
191 reservedOp "::"
192 return relVarName
193 attributes <- makeAttributes
194 return $ Define relVarName attributes
196deleteP :: Parser DatabaseExpr
197deleteP = do
198 reservedOp "delete"
199 relVarName <- identifier
200 return $ Delete relVarName
202updateP :: Parser DatabaseExpr
203updateP = do
204 reservedOp "update"
205 relVarName <- identifier
206 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
207 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
208 return $ Update relVarName attributeAssignments predicate
210constraintP :: Parser DatabaseExpr
211constraintP = do
212 reservedOp "constraint"
213 constraintName <- identifier
214 subset <- relExpr
215 reservedOp "in"
216 superset <- relExpr
217 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
219attributeAssignment :: Parser (String, Atom)
220attributeAssignment = do
221 attrName <- identifier
222 reservedOp ":="
223 atom <- stringAtomP <|> intAtomP
224 return $ (attrName, atom)
226parseString :: String -> Either RelationalError DatabaseExpr
227parseString str = case parse multipleDatabaseExpr "" str of
228 Left err -> Left $ ParseError (show err)
229 Right r -> Right r
231data TutorialDOperator where
232 ShowRelation :: RelationalExpr -> TutorialDOperator
233 ShowRelationType :: RelationalExpr -> TutorialDOperator
234 ShowConstraint :: String -> TutorialDOperator
235 Quit :: TutorialDOperator
236 deriving (Show)
238typeP :: Parser TutorialDOperator
239typeP = do
240 reservedOp ":t"
241 expr <- relExpr
242 return $ ShowRelationType expr
244showRelP :: Parser TutorialDOperator
245showRelP = do
246 reservedOp ":s"
247 expr <- relExpr
248 return $ ShowRelation expr
250quitP :: Parser TutorialDOperator
251quitP = do
252 reservedOp ":q"
253 return Quit
255showConstraintsP :: Parser TutorialDOperator
256showConstraintsP = do
257 reservedOp ":c"
258 constraintName <- option "" identifier
259 return $ ShowConstraint constraintName
261interpreterOps :: Parser TutorialDOperator
262interpreterOps = typeP
263 <|> showRelP
264 <|> showConstraintsP
265 <|> quitP
267showRelationAttributes :: Relation -> String
268showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
269 where
270 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
271 Just t -> show t
272 Nothing -> "unknown"
273 attrs = values (attributes rel)
274 values m = map snd (M.toAscList m)
276data TutorialDOperatorResult = QuitResult |
277 DisplayResult String |
278 DisplayErrorResult String |
279 NoActionResult
281evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
282evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
283 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
284 (Left err, _) -> DisplayErrorResult $ show err
286evalTutorialDOp context (ShowRelation expr) = do
287 case runState (evalRelationalExpr expr) context of
288 (Left err, _) -> DisplayErrorResult $ show err
289 (Right rel, _) -> DisplayResult $ showRelation rel
291evalTutorialDOp context (ShowConstraint name) = do
292 DisplayResult $ show filteredDeps
293 where
294 deps = inclusionDependencies context
295 filteredDeps = case name of
296 "" -> deps
297 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
299evalTutorialDOp context (Quit) = QuitResult
301example1 = "relA {a,b, c}"
302example2 = "relA join relB"
303example3 = "relA join relB {x,y,z}"
304example4 = "(relA) {x,y,z}"
305example5 = "relA union relB"
306example6 = "rv1 := true"
307example7 = "rv1 := relA union relB"
308example8 = "relA := true; relB := false"
309example9 = "relA := relation { SNO CHAR }"
311interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
312interpret context tutdstring = case parseString tutdstring of
313 Left err -> (Just err, context)
314 Right parsed -> runState (evalContextExpr parsed) context
316-- for interpreter-specific operations
317interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
318interpretOps context instring = case parse interpreterOps "" instring of
319 Left err -> NoActionResult
320 Right ops -> evalTutorialDOp context ops
322reprLoop :: DatabaseContext -> IO ()
323reprLoop context = do
324 maybeLine <- readline "TutorialD: "
325 case maybeLine of
326 Nothing -> return ()
327 Just line -> do
328 addHistory line
330 case interpretOps context line of
331 QuitResult -> return ()
332 DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err)
333 DisplayResult out -> do
334 putStrLn out
335 reprLoop context
336 NoActionResult -> do
337 let (value, contextup) = interpret context line
338 case value of
339 Nothing -> reprLoop contextup
340 (Just err) -> do
341 hPutStrLn stderr ("ERR:" ++ show err)
342 reprLoop context
344restrictionPredicateP :: Parser RestrictionPredicateExpr
345restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
346 where
347 predicateOperators = [
348 [Prefix (reservedOp "not" >> return NotPredicate)],
349 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
350 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
351 ]
352 predicateTerm = parens restrictionPredicateP
353 <|> try restrictionAttributeEqualityP
354 <|> try relationalBooleanExpr
357relationalBooleanExpr :: Parser RestrictionPredicateExpr
358relationalBooleanExpr = do
359 relexpr <- relExpr
360 return $ RelationalExprPredicate relexpr
362restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
363restrictionAttributeEqualityP = do
364 attributeName <- identifier
365 reservedOp "="
366 atom <- stringAtomP <|> intAtomP
367 return $ AttributeEqualityPredicate attributeName atom
369quotedChar = noneOf "\""
370 <|> try (string "\"\"" >> return '"')
372stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
374intAtomP = do
375 intstr <- many digit
376 return $ IntAtom (read intstr)