git.iko.soy/project-m36
on 839ee52 help sign in
project-m36/TutorialDInterpreter.hs
422 lines 14 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialDInterpreter where
3import Relation
4import RelationType
5import RelationTuple
6import RelationTupleSet
7import RelationalError
8import RelationExpr
9import RelationTerm
10import RelationStaticOptimizer
11import Text.Parsec
12import Text.Parsec.String
13import Text.Parsec.Expr
14import Text.Parsec.Language
15import qualified Text.Parsec.Token as Token
16import qualified Data.Set as S
17import qualified Data.HashSet as HS
18import qualified Data.Map as M
19import qualified Data.List as L
20import Control.Applicative (liftA, (<*), (*>))
21import Control.Monad.State
22import System.Console.Haskeline
23import System.IO
24import System.Directory (getHomeDirectory)
26lexer :: Token.TokenParser ()
27lexer = Token.makeTokenParser tutD
28 where tutD = emptyDef {
29 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
30 Token.reservedNames = [],
31 Token.identStart = letter <|> char '_',
32 Token.identLetter = alphaNum <|> char '_' <|> char '#'} -- # needed for Date examples
34parens = Token.parens lexer
35reservedOp = Token.reservedOp lexer
36reserved = Token.reserved lexer
37braces = Token.braces lexer
38identifier = Token.identifier lexer
39comma = Token.comma lexer
40semi = Token.semi lexer
42--used in projection
43attributeList :: Parser [AttributeName]
44attributeList = sepBy identifier comma
46makeRelation :: Parser RelationalExpr
47makeRelation = do
48 reservedOp "relation"
49 attrs <- (try makeAttributes <|> return M.empty)
50 if not (M.null attrs) then do
51 return $ MakeStaticRelation attrs emptyTupleSet
52 else do
53 tuples <- braces (sepBy tupleP comma)
54 return $ MakeStaticRelation (tupleAttributes (head tuples)) (HS.fromList tuples)
56--used in relation creation
57makeAttributes :: Parser Attributes
58makeAttributes = do
59 attrList <- braces (sepBy attributeAndType comma)
60 return $ M.fromList $ map toAttributeAssocList attrList
61 where
62 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
64attributeAndType :: Parser Attribute
65attributeAndType = do
66 attrName <- identifier
67 attrTypeName <- identifier
68 --convert type name into type
69 case tutDTypeToAtomType attrTypeName of
70 Just t -> return $ Attribute attrName t
71 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
73tupleP :: Parser RelationTuple
74tupleP = do
75 reservedOp "tuple"
76 attrValues <- braces (sepBy tupleAtomP comma)
77 return $ RelationTuple (M.fromList attrValues)
79tupleAtomP :: Parser (AttributeName, Atom)
80tupleAtomP = do
81 attributeName <- identifier
82 attrType <- identifier
83 atom <- parens (stringAtomP <|> intAtomP)
84 case tutDTypeToAtomType attrType of
85 Nothing -> fail (attrType ++ " is not a valid type name.")
86 Just typeA -> if typeA == atomTypeForAtom atom then
87 return $ (attributeName, atom)
88 else
89 fail "type mismatch in tuple generation"
91--convert Tutorial D type to AtomType
92tutDTypeToAtomType :: String -> Maybe AtomType
93tutDTypeToAtomType tutDType = case tutDType of
94 "char" -> Just StringAtomType
95 "int" -> Just IntAtomType
96 _ -> Nothing
98atomTypeToTutDType :: AtomType -> Maybe String
99atomTypeToTutDType atomType = case atomType of
100 StringAtomType -> Just "char"
101 IntAtomType -> Just "int"
102 --RelationAtomType rel ->
103 _ -> Nothing
105relVarP :: Parser RelationalExpr
106relVarP = liftA RelationVariable identifier
108relTerm = parens relExpr
109 <|> makeRelation
110 <|> relVarP
112projectOp = do
113 attrs <- braces attributeList
114 return $ Project (S.fromList attrs)
116assignP :: Parser DatabaseExpr
117assignP = do
118 relVarName <- try $ do
119 relVarName <- identifier
120 reservedOp ":="
121 return relVarName
122 expr <- relExpr
123 return $ Assign relVarName expr
125renameClause = do
126 oldAttr <- identifier
127 reservedOp "as"
128 newAttr <- identifier
129 return $ (oldAttr, newAttr)
131renameP :: Parser (RelationalExpr -> RelationalExpr)
132renameP = do
133 reservedOp "rename"
134 (oldAttr, newAttr) <- braces renameClause
135 return $ Rename oldAttr newAttr
137whereClauseP = do
138 reservedOp "where"
139 boolExpr <- restrictionPredicateP
140 return $ Restrict boolExpr
142groupClause = do
143 attrs <- braces attributeList
144 reservedOp "as"
145 newAttrName <- identifier
146 return $ (attrs, newAttrName)
148groupP :: Parser (RelationalExpr -> RelationalExpr)
149groupP = do
150 reservedOp "group"
151 (groupAttrList, groupAttrName) <- parens groupClause
152 return $ Group (S.fromList groupAttrList) groupAttrName
154--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.
155ungroupP :: Parser (RelationalExpr -> RelationalExpr)
156ungroupP = do
157 reservedOp "ungroup"
158 rvaAttrName <- identifier
159 return $ Ungroup rvaAttrName
161relOperators = [
162 [Postfix projectOp],
163 [Postfix renameP],
164 [Postfix whereClauseP],
165 [Postfix groupP],
166 [Postfix ungroupP],
167 [Infix (reservedOp "join" >> return Join) AssocLeft],
168 [Infix (reservedOp "union" >> return Union) AssocLeft],
169 [Infix (reservedOp "=" >> return Equals) AssocNone]
170 ]
172relExpr :: Parser RelationalExpr
173relExpr = buildExpressionParser relOperators relTerm
175databaseExpr :: Parser DatabaseExpr
176databaseExpr = insertP
177 <|> deleteP
178 <|> updateP
179 <|> constraintP
180 <|> defineP
181 <|> undefineP
182 <|> assignP
184multipleDatabaseExpr :: Parser DatabaseExpr
185multipleDatabaseExpr = do
186 exprs <- sepBy1 databaseExpr semi
187 return $ MultipleExpr exprs
189insertP :: Parser DatabaseExpr
190insertP = do
191 reservedOp "insert"
192 relvar <- identifier
193 expr <- relExpr
194 return $ Insert relvar expr
196defineP :: Parser DatabaseExpr
197defineP = do
198 relVarName <- try $ do
199 relVarName <- identifier
200 reservedOp "::"
201 return relVarName
202 attributes <- makeAttributes
203 return $ Define relVarName attributes
205undefineP :: Parser DatabaseExpr
206undefineP = do
207 reservedOp "undefine"
208 relVarName <- identifier
209 return $ Undefine relVarName
211deleteP :: Parser DatabaseExpr
212deleteP = do
213 reservedOp "delete"
214 relVarName <- identifier
215 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
216 return $ Delete relVarName predicate
218updateP :: Parser DatabaseExpr
219updateP = do
220 reservedOp "update"
221 relVarName <- identifier
222 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
223 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
224 return $ Update relVarName attributeAssignments predicate
226constraintP :: Parser DatabaseExpr
227constraintP = do
228 reservedOp "constraint"
229 constraintName <- identifier
230 subset <- relExpr
231 reservedOp "in"
232 superset <- relExpr
233 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
235attributeAssignment :: Parser (String, Atom)
236attributeAssignment = do
237 attrName <- identifier
238 reservedOp ":="
239 atom <- stringAtomP <|> intAtomP
240 return $ (attrName, atom)
242parseString :: String -> Either RelationalError DatabaseExpr
243parseString str = case parse (multipleDatabaseExpr <* eof) "" str of
244 Left err -> Left $ ParseError (show err)
245 Right r -> Right r
247data TutorialDOperator where
248 ShowRelation :: RelationalExpr -> TutorialDOperator
249 ShowRelationType :: RelationalExpr -> TutorialDOperator
250 ShowConstraint :: String -> TutorialDOperator
251 ShowPlan :: DatabaseExpr -> TutorialDOperator
252 Quit :: TutorialDOperator
253 deriving (Show)
255typeP :: Parser TutorialDOperator
256typeP = do
257 reservedOp ":t"
258 expr <- relExpr
259 return $ ShowRelationType expr
261showRelP :: Parser TutorialDOperator
262showRelP = do
263 reservedOp ":s"
264 expr <- relExpr <* eof
265 return $ ShowRelation expr
267showPlanP :: Parser TutorialDOperator
268showPlanP = do
269 reservedOp ":p"
270 expr <- databaseExpr
271 return $ ShowPlan expr
273quitP :: Parser TutorialDOperator
274quitP = do
275 reservedOp ":q"
276 return Quit
278showConstraintsP :: Parser TutorialDOperator
279showConstraintsP = do
280 reservedOp ":c"
281 constraintName <- option "" identifier
282 return $ ShowConstraint constraintName
284interpreterOps :: Parser TutorialDOperator
285interpreterOps = typeP
286 <|> showRelP
287 <|> showConstraintsP
288 <|> showPlanP
289 <|> quitP
291showRelationAttributes :: Relation -> String
292showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
293 where
294 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
295 Just t -> show t
296 Nothing -> "unknown"
297 attrs = values (attributes rel)
298 values m = map snd (M.toAscList m)
300data TutorialDOperatorResult = QuitResult |
301 DisplayResult String |
302 DisplayErrorResult String |
303 NoActionResult
305evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
306evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
307 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
308 (Left err, _) -> DisplayErrorResult $ show err
310evalTutorialDOp context (ShowRelation expr) = do
311 case runState (evalRelationalExpr expr) context of
312 (Left err, _) -> DisplayErrorResult $ show err
313 (Right rel, _) -> DisplayResult $ showRelation rel
315evalTutorialDOp context (ShowConstraint name) = do
316 DisplayResult $ show filteredDeps
317 where
318 deps = inclusionDependencies context
319 filteredDeps = case name of
320 "" -> deps
321 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
323evalTutorialDOp context (ShowPlan dbExpr) = do
324 DisplayResult $ show plan
325 where
326 plan = evalState (applyStaticDatabaseOptimization dbExpr) context
328evalTutorialDOp context (Quit) = QuitResult
330example1 = "relA {a,b, c}"
331example2 = "relA join relB"
332example3 = "relA join relB {x,y,z}"
333example4 = "(relA) {x,y,z}"
334example5 = "relA union relB"
335example6 = "rv1 := true"
336example7 = "rv1 := relA union relB"
337example8 = "relA := true; relB := false"
338example9 = "relA := relation { SNO CHAR }"
340interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
341interpret context tutdstring = case parseString tutdstring of
342 Left err -> (Just err, context)
343 Right parsed -> runState (evaluator parsed) context
344 where
345 evaluator expr = do
346 context <- get
347 optExpr <- applyStaticDatabaseOptimization expr
348 --case optExpr of
349 case optExpr of
350 Left err -> return $ Just err
351 Right optExprA -> evalContextExpr optExprA
353--no optimization
354interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
355interpretNO context tutdstring = case parseString tutdstring of
356 Left err -> (Just err, context)
357 Right parsed -> runState (evalContextExpr parsed) context
360-- for interpreter-specific operations
361interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
362interpretOps context instring = case parse interpreterOps "" instring of
363 Left err -> NoActionResult
364 Right ops -> evalTutorialDOp context ops
366reprLoop :: DatabaseContext -> IO ()
367reprLoop context = do
368 homeDirectory <- getHomeDirectory
369 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
370 maybeLine <- runInputT settings $ do
371 getInputLine "TutorialD: "
372 case maybeLine of
373 Nothing -> return ()
374 Just line -> do
375 case interpretOps context line of
376 QuitResult -> return ()
377 DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context
378 DisplayResult out -> do
379 putStrLn out
380 reprLoop context
381 NoActionResult -> do
382 let (value, contextup) = interpret context line
383 case value of
384 Nothing -> reprLoop contextup
385 (Just err) -> do
386 hPutStrLn stderr ("ERR:" ++ show err)
387 reprLoop context
389restrictionPredicateP :: Parser RestrictionPredicateExpr
390restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
391 where
392 predicateOperators = [
393 [Prefix (reservedOp "not" >> return NotPredicate)],
394 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
395 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
396 ]
397 predicateTerm = parens restrictionPredicateP
398 <|> try restrictionAttributeEqualityP
399 <|> try relationalBooleanExpr
402relationalBooleanExpr :: Parser RestrictionPredicateExpr
403relationalBooleanExpr = do
404 relexpr <- relExpr
405 return $ RelationalExprPredicate relexpr
407restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
408restrictionAttributeEqualityP = do
409 attributeName <- identifier
410 reservedOp "="
411 atom <- stringAtomP <|> intAtomP
412 return $ AttributeEqualityPredicate attributeName atom
414quotedChar = noneOf "\""
415 <|> try (string "\"\"" >> return '"')
417stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
419intAtomP = do
420 intstr <- many digit
421 return $ IntAtom (read intstr)