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