git.iko.soy/project-m36
on f86177e help sign in
project-m36/TutorialDInterpreter.hs
409 lines 13 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 "" 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 Quit :: TutorialDOperator
252 deriving (Show)
254typeP :: Parser TutorialDOperator
255typeP = do
256 reservedOp ":t"
257 expr <- relExpr
258 return $ ShowRelationType expr
260showRelP :: Parser TutorialDOperator
261showRelP = do
262 reservedOp ":s"
263 expr <- relExpr
264 return $ ShowRelation expr
266quitP :: Parser TutorialDOperator
267quitP = do
268 reservedOp ":q"
269 return Quit
271showConstraintsP :: Parser TutorialDOperator
272showConstraintsP = do
273 reservedOp ":c"
274 constraintName <- option "" identifier
275 return $ ShowConstraint constraintName
277interpreterOps :: Parser TutorialDOperator
278interpreterOps = typeP
279 <|> showRelP
280 <|> showConstraintsP
281 <|> quitP
283showRelationAttributes :: Relation -> String
284showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
285 where
286 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
287 Just t -> show t
288 Nothing -> "unknown"
289 attrs = values (attributes rel)
290 values m = map snd (M.toAscList m)
292data TutorialDOperatorResult = QuitResult |
293 DisplayResult String |
294 DisplayErrorResult String |
295 NoActionResult
297evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
298evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
299 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
300 (Left err, _) -> DisplayErrorResult $ show err
302evalTutorialDOp context (ShowRelation expr) = do
303 case runState (evalRelationalExpr expr) context of
304 (Left err, _) -> DisplayErrorResult $ show err
305 (Right rel, _) -> DisplayResult $ showRelation rel
307evalTutorialDOp context (ShowConstraint name) = do
308 DisplayResult $ show filteredDeps
309 where
310 deps = inclusionDependencies context
311 filteredDeps = case name of
312 "" -> deps
313 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
315evalTutorialDOp context (Quit) = QuitResult
317example1 = "relA {a,b, c}"
318example2 = "relA join relB"
319example3 = "relA join relB {x,y,z}"
320example4 = "(relA) {x,y,z}"
321example5 = "relA union relB"
322example6 = "rv1 := true"
323example7 = "rv1 := relA union relB"
324example8 = "relA := true; relB := false"
325example9 = "relA := relation { SNO CHAR }"
327interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
328interpret context tutdstring = case parseString tutdstring of
329 Left err -> (Just err, context)
330 Right parsed -> runState (evaluator parsed) context
331 where
332 evaluator expr = do
333 context <- get
334 optExpr <- applyStaticDatabaseOptimization expr
335 --case optExpr of
336 case optExpr of
337 Left err -> return $ Just err
338 Right optExprA -> evalContextExpr optExprA
340--no optimization
341interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
342interpretNO context tutdstring = case parseString tutdstring of
343 Left err -> (Just err, context)
344 Right parsed -> runState (evalContextExpr parsed) context
347-- for interpreter-specific operations
348interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
349interpretOps context instring = case parse interpreterOps "" instring of
350 Left err -> NoActionResult
351 Right ops -> evalTutorialDOp context ops
353reprLoop :: DatabaseContext -> IO ()
354reprLoop context = do
355 homeDirectory <- getHomeDirectory
356 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
357 maybeLine <- runInputT settings $ do
358 getInputLine "TutorialD: "
359 case maybeLine of
360 Nothing -> return ()
361 Just line -> do
362 case interpretOps context line of
363 QuitResult -> return ()
364 DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context
365 DisplayResult out -> do
366 putStrLn out
367 reprLoop context
368 NoActionResult -> do
369 let (value, contextup) = interpret context line
370 case value of
371 Nothing -> reprLoop contextup
372 (Just err) -> do
373 hPutStrLn stderr ("ERR:" ++ show err)
374 reprLoop context
376restrictionPredicateP :: Parser RestrictionPredicateExpr
377restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
378 where
379 predicateOperators = [
380 [Prefix (reservedOp "not" >> return NotPredicate)],
381 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
382 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
383 ]
384 predicateTerm = parens restrictionPredicateP
385 <|> try restrictionAttributeEqualityP
386 <|> try relationalBooleanExpr
389relationalBooleanExpr :: Parser RestrictionPredicateExpr
390relationalBooleanExpr = do
391 relexpr <- relExpr
392 return $ RelationalExprPredicate relexpr
394restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
395restrictionAttributeEqualityP = do
396 attributeName <- identifier
397 reservedOp "="
398 atom <- stringAtomP <|> intAtomP
399 return $ AttributeEqualityPredicate attributeName atom
401quotedChar = noneOf "\""
402 <|> try (string "\"\"" >> return '"')
404stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
406intAtomP = do
407 intstr <- many digit
408 return $ IntAtom (read intstr)