git.iko.soy/project-m36
on 383f6ef help sign in
project-m36/TutorialDInterpreter.hs
385 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.Haskeline
22import System.IO
23import System.Directory (getHomeDirectory)
25lexer :: Token.TokenParser ()
26lexer = Token.makeTokenParser tutD
27 where tutD = emptyDef {
28 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
29 Token.reservedNames = [],
30 Token.identStart = letter <|> char '_',
31 Token.identLetter = alphaNum <|> char '_'}
33parens = Token.parens lexer
34reservedOp = Token.reservedOp lexer
35reserved = Token.reserved lexer
36braces = Token.braces lexer
37identifier = Token.identifier lexer
38comma = Token.comma lexer
39semi = Token.semi lexer
41--used in projection
42attributeList :: Parser [AttributeName]
43attributeList = sepBy identifier comma
45makeRelation :: Parser RelationalExpr
46makeRelation = do
47 reservedOp "relation"
48 attrs <- (try makeAttributes <|> return M.empty)
49 if not (M.null attrs) then do
50 return $ MakeStaticRelation attrs emptyTupleSet
51 else do
52 tuples <- braces (sepBy tupleP comma)
53 return $ MakeStaticRelation (tupleAttributes (head tuples)) (HS.fromList tuples)
55--used in relation creation
56makeAttributes :: Parser Attributes
57makeAttributes = do
58 attrList <- braces (sepBy attributeAndType comma)
59 return $ M.fromList $ map toAttributeAssocList attrList
60 where
61 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
63attributeAndType :: Parser Attribute
64attributeAndType = do
65 attrName <- identifier
66 attrTypeName <- identifier
67 --convert type name into type
68 case tutDTypeToAtomType attrTypeName of
69 Just t -> return $ Attribute attrName t
70 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
72tupleP :: Parser RelationTuple
73tupleP = do
74 reservedOp "tuple"
75 attrValues <- braces (sepBy tupleAtomP comma)
76 return $ RelationTuple (M.fromList attrValues)
78tupleAtomP :: Parser (AttributeName, Atom)
79tupleAtomP = do
80 attributeName <- identifier
81 attrType <- identifier
82 atom <- parens (stringAtomP <|> intAtomP)
83 case tutDTypeToAtomType attrType of
84 Nothing -> fail (attrType ++ " is not a valid type name.")
85 Just typeA -> if typeA == atomTypeForAtom atom then
86 return $ (attributeName, atom)
87 else
88 fail "type mismatch in tuple generation"
90--convert Tutorial D type to AtomType
91tutDTypeToAtomType :: String -> Maybe AtomType
92tutDTypeToAtomType tutDType = case tutDType of
93 "char" -> Just StringAtomType
94 "int" -> Just IntAtomType
95 _ -> Nothing
97atomTypeToTutDType :: AtomType -> Maybe String
98atomTypeToTutDType atomType = case atomType of
99 StringAtomType -> Just "char"
100 IntAtomType -> Just "int"
101 --RelationAtomType rel ->
102 _ -> Nothing
104relVarP :: Parser RelationalExpr
105relVarP = liftA RelationVariable identifier
107relTerm = parens relExpr
108 <|> makeRelation
109 <|> relVarP
111projectOp = do
112 attrs <- braces attributeList
113 return $ Project (S.fromList attrs)
115assignP :: Parser DatabaseExpr
116assignP = do
117 relVarName <- try $ do
118 relVarName <- identifier
119 reservedOp ":="
120 return relVarName
121 expr <- relExpr
122 return $ Assign relVarName expr
124renameClause = do
125 oldAttr <- identifier
126 reservedOp "as"
127 newAttr <- identifier
128 return $ (oldAttr, newAttr)
130renameP :: Parser (RelationalExpr -> RelationalExpr)
131renameP = do
132 reservedOp "rename"
133 (oldAttr, newAttr) <- braces renameClause
134 return $ Rename oldAttr newAttr
136whereClauseP = do
137 reservedOp "where"
138 boolExpr <- restrictionPredicateP
139 return $ Restrict boolExpr
141groupClause = do
142 attrs <- braces attributeList
143 reservedOp "as"
144 newAttrName <- identifier
145 return $ (attrs, newAttrName)
147groupP :: Parser (RelationalExpr -> RelationalExpr)
148groupP = do
149 reservedOp "group"
150 (groupAttrList, groupAttrName) <- parens groupClause
151 return $ Group (S.fromList groupAttrList) groupAttrName
153--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.
154ungroupP :: Parser (RelationalExpr -> RelationalExpr)
155ungroupP = do
156 reservedOp "ungroup"
157 rvaAttrName <- identifier
158 return $ Ungroup rvaAttrName
160relOperators = [
161 [Postfix projectOp],
162 [Postfix renameP],
163 [Postfix whereClauseP],
164 [Postfix groupP],
165 [Postfix ungroupP],
166 [Infix (reservedOp "join" >> return Join) AssocLeft],
167 [Infix (reservedOp "union" >> return Union) AssocLeft],
168 [Infix (reservedOp "=" >> return Equals) AssocNone]
169 ]
171relExpr :: Parser RelationalExpr
172relExpr = buildExpressionParser relOperators relTerm
174databaseExpr :: Parser DatabaseExpr
175databaseExpr = insertP
176 <|> deleteP
177 <|> updateP
178 <|> constraintP
179 <|> defineP
180 <|> assignP
182multipleDatabaseExpr :: Parser DatabaseExpr
183multipleDatabaseExpr = do
184 exprs <- sepBy1 databaseExpr semi
185 return $ MultipleExpr exprs
187insertP :: Parser DatabaseExpr
188insertP = do
189 reservedOp "insert"
190 relvar <- identifier
191 expr <- relExpr
192 return $ Insert relvar expr
194defineP :: Parser DatabaseExpr
195defineP = do
196 relVarName <- try $ do
197 relVarName <- identifier
198 reservedOp "::"
199 return relVarName
200 attributes <- makeAttributes
201 return $ Define relVarName attributes
203deleteP :: Parser DatabaseExpr
204deleteP = do
205 reservedOp "delete"
206 relVarName <- identifier
207 return $ Delete relVarName
209updateP :: Parser DatabaseExpr
210updateP = do
211 reservedOp "update"
212 relVarName <- identifier
213 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
214 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
215 return $ Update relVarName attributeAssignments predicate
217constraintP :: Parser DatabaseExpr
218constraintP = do
219 reservedOp "constraint"
220 constraintName <- identifier
221 subset <- relExpr
222 reservedOp "in"
223 superset <- relExpr
224 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
226attributeAssignment :: Parser (String, Atom)
227attributeAssignment = do
228 attrName <- identifier
229 reservedOp ":="
230 atom <- stringAtomP <|> intAtomP
231 return $ (attrName, atom)
233parseString :: String -> Either RelationalError DatabaseExpr
234parseString str = case parse multipleDatabaseExpr "" str of
235 Left err -> Left $ ParseError (show err)
236 Right r -> Right r
238data TutorialDOperator where
239 ShowRelation :: RelationalExpr -> TutorialDOperator
240 ShowRelationType :: RelationalExpr -> TutorialDOperator
241 ShowConstraint :: String -> TutorialDOperator
242 Quit :: TutorialDOperator
243 deriving (Show)
245typeP :: Parser TutorialDOperator
246typeP = do
247 reservedOp ":t"
248 expr <- relExpr
249 return $ ShowRelationType expr
251showRelP :: Parser TutorialDOperator
252showRelP = do
253 reservedOp ":s"
254 expr <- relExpr
255 return $ ShowRelation expr
257quitP :: Parser TutorialDOperator
258quitP = do
259 reservedOp ":q"
260 return Quit
262showConstraintsP :: Parser TutorialDOperator
263showConstraintsP = do
264 reservedOp ":c"
265 constraintName <- option "" identifier
266 return $ ShowConstraint constraintName
268interpreterOps :: Parser TutorialDOperator
269interpreterOps = typeP
270 <|> showRelP
271 <|> showConstraintsP
272 <|> quitP
274showRelationAttributes :: Relation -> String
275showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
276 where
277 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
278 Just t -> show t
279 Nothing -> "unknown"
280 attrs = values (attributes rel)
281 values m = map snd (M.toAscList m)
283data TutorialDOperatorResult = QuitResult |
284 DisplayResult String |
285 DisplayErrorResult String |
286 NoActionResult
288evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
289evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
290 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
291 (Left err, _) -> DisplayErrorResult $ show err
293evalTutorialDOp context (ShowRelation expr) = do
294 case runState (evalRelationalExpr expr) context of
295 (Left err, _) -> DisplayErrorResult $ show err
296 (Right rel, _) -> DisplayResult $ showRelation rel
298evalTutorialDOp context (ShowConstraint name) = do
299 DisplayResult $ show filteredDeps
300 where
301 deps = inclusionDependencies context
302 filteredDeps = case name of
303 "" -> deps
304 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
306evalTutorialDOp context (Quit) = QuitResult
308example1 = "relA {a,b, c}"
309example2 = "relA join relB"
310example3 = "relA join relB {x,y,z}"
311example4 = "(relA) {x,y,z}"
312example5 = "relA union relB"
313example6 = "rv1 := true"
314example7 = "rv1 := relA union relB"
315example8 = "relA := true; relB := false"
316example9 = "relA := relation { SNO CHAR }"
318interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
319interpret context tutdstring = case parseString tutdstring of
320 Left err -> (Just err, context)
321 Right parsed -> runState (evalContextExpr parsed) context
323-- for interpreter-specific operations
324interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
325interpretOps context instring = case parse interpreterOps "" instring of
326 Left err -> NoActionResult
327 Right ops -> evalTutorialDOp context ops
329reprLoop :: DatabaseContext -> IO ()
330reprLoop context = do
331 homeDirectory <- getHomeDirectory
332 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
333 maybeLine <- runInputT settings $ do
334 getInputLine "TutorialD: "
335 case maybeLine of
336 Nothing -> return ()
337 Just line -> do
338 case interpretOps context line of
339 QuitResult -> return ()
340 DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context
341 DisplayResult out -> do
342 putStrLn out
343 reprLoop context
344 NoActionResult -> do
345 let (value, contextup) = interpret context line
346 case value of
347 Nothing -> reprLoop contextup
348 (Just err) -> do
349 hPutStrLn stderr ("ERR:" ++ show err)
350 reprLoop context
352restrictionPredicateP :: Parser RestrictionPredicateExpr
353restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
354 where
355 predicateOperators = [
356 [Prefix (reservedOp "not" >> return NotPredicate)],
357 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
358 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
359 ]
360 predicateTerm = parens restrictionPredicateP
361 <|> try restrictionAttributeEqualityP
362 <|> try relationalBooleanExpr
365relationalBooleanExpr :: Parser RestrictionPredicateExpr
366relationalBooleanExpr = do
367 relexpr <- relExpr
368 return $ RelationalExprPredicate relexpr
370restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
371restrictionAttributeEqualityP = do
372 attributeName <- identifier
373 reservedOp "="
374 atom <- stringAtomP <|> intAtomP
375 return $ AttributeEqualityPredicate attributeName atom
377quotedChar = noneOf "\""
378 <|> try (string "\"\"" >> return '"')
380stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
382intAtomP = do
383 intstr <- many digit
384 return $ IntAtom (read intstr)