git.iko.soy/project-m36
on 44ec3cd help sign in
project-m36/TutorialDInterpreter.hs
393 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 <|> undefineP
181 <|> assignP
183multipleDatabaseExpr :: Parser DatabaseExpr
184multipleDatabaseExpr = do
185 exprs <- sepBy1 databaseExpr semi
186 return $ MultipleExpr exprs
188insertP :: Parser DatabaseExpr
189insertP = do
190 reservedOp "insert"
191 relvar <- identifier
192 expr <- relExpr
193 return $ Insert relvar expr
195defineP :: Parser DatabaseExpr
196defineP = do
197 relVarName <- try $ do
198 relVarName <- identifier
199 reservedOp "::"
200 return relVarName
201 attributes <- makeAttributes
202 return $ Define relVarName attributes
204undefineP :: Parser DatabaseExpr
205undefineP = do
206 reservedOp "undefine"
207 relVarName <- identifier
208 return $ Undefine relVarName
210deleteP :: Parser DatabaseExpr
211deleteP = do
212 reservedOp "delete"
213 relVarName <- identifier
214 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)
215 return $ Delete relVarName predicate
217updateP :: Parser DatabaseExpr
218updateP = do
219 reservedOp "update"
220 relVarName <- identifier
221 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaces)
222 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
223 return $ Update relVarName attributeAssignments predicate
225constraintP :: Parser DatabaseExpr
226constraintP = do
227 reservedOp "constraint"
228 constraintName <- identifier
229 subset <- relExpr
230 reservedOp "in"
231 superset <- relExpr
232 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
234attributeAssignment :: Parser (String, Atom)
235attributeAssignment = do
236 attrName <- identifier
237 reservedOp ":="
238 atom <- stringAtomP <|> intAtomP
239 return $ (attrName, atom)
241parseString :: String -> Either RelationalError DatabaseExpr
242parseString str = case parse multipleDatabaseExpr "" str of
243 Left err -> Left $ ParseError (show err)
244 Right r -> Right r
246data TutorialDOperator where
247 ShowRelation :: RelationalExpr -> TutorialDOperator
248 ShowRelationType :: RelationalExpr -> TutorialDOperator
249 ShowConstraint :: String -> TutorialDOperator
250 Quit :: TutorialDOperator
251 deriving (Show)
253typeP :: Parser TutorialDOperator
254typeP = do
255 reservedOp ":t"
256 expr <- relExpr
257 return $ ShowRelationType expr
259showRelP :: Parser TutorialDOperator
260showRelP = do
261 reservedOp ":s"
262 expr <- relExpr
263 return $ ShowRelation expr
265quitP :: Parser TutorialDOperator
266quitP = do
267 reservedOp ":q"
268 return Quit
270showConstraintsP :: Parser TutorialDOperator
271showConstraintsP = do
272 reservedOp ":c"
273 constraintName <- option "" identifier
274 return $ ShowConstraint constraintName
276interpreterOps :: Parser TutorialDOperator
277interpreterOps = typeP
278 <|> showRelP
279 <|> showConstraintsP
280 <|> quitP
282showRelationAttributes :: Relation -> String
283showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
284 where
285 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
286 Just t -> show t
287 Nothing -> "unknown"
288 attrs = values (attributes rel)
289 values m = map snd (M.toAscList m)
291data TutorialDOperatorResult = QuitResult |
292 DisplayResult String |
293 DisplayErrorResult String |
294 NoActionResult
296evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> TutorialDOperatorResult
297evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
298 (Right rel, _) -> DisplayResult $ showRelationAttributes rel
299 (Left err, _) -> DisplayErrorResult $ show err
301evalTutorialDOp context (ShowRelation expr) = do
302 case runState (evalRelationalExpr expr) context of
303 (Left err, _) -> DisplayErrorResult $ show err
304 (Right rel, _) -> DisplayResult $ showRelation rel
306evalTutorialDOp context (ShowConstraint name) = do
307 DisplayResult $ show filteredDeps
308 where
309 deps = inclusionDependencies context
310 filteredDeps = case name of
311 "" -> deps
312 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
314evalTutorialDOp context (Quit) = QuitResult
316example1 = "relA {a,b, c}"
317example2 = "relA join relB"
318example3 = "relA join relB {x,y,z}"
319example4 = "(relA) {x,y,z}"
320example5 = "relA union relB"
321example6 = "rv1 := true"
322example7 = "rv1 := relA union relB"
323example8 = "relA := true; relB := false"
324example9 = "relA := relation { SNO CHAR }"
326interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
327interpret context tutdstring = case parseString tutdstring of
328 Left err -> (Just err, context)
329 Right parsed -> runState (evalContextExpr parsed) context
331-- for interpreter-specific operations
332interpretOps :: DatabaseContext -> String -> TutorialDOperatorResult
333interpretOps context instring = case parse interpreterOps "" instring of
334 Left err -> NoActionResult
335 Right ops -> evalTutorialDOp context ops
337reprLoop :: DatabaseContext -> IO ()
338reprLoop context = do
339 homeDirectory <- getHomeDirectory
340 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
341 maybeLine <- runInputT settings $ do
342 getInputLine "TutorialD: "
343 case maybeLine of
344 Nothing -> return ()
345 Just line -> do
346 case interpretOps context line of
347 QuitResult -> return ()
348 DisplayErrorResult err -> hPutStrLn stderr ("ERR: " ++ err) >> reprLoop context
349 DisplayResult out -> do
350 putStrLn out
351 reprLoop context
352 NoActionResult -> do
353 let (value, contextup) = interpret context line
354 case value of
355 Nothing -> reprLoop contextup
356 (Just err) -> do
357 hPutStrLn stderr ("ERR:" ++ show err)
358 reprLoop context
360restrictionPredicateP :: Parser RestrictionPredicateExpr
361restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
362 where
363 predicateOperators = [
364 [Prefix (reservedOp "not" >> return NotPredicate)],
365 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
366 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
367 ]
368 predicateTerm = parens restrictionPredicateP
369 <|> try restrictionAttributeEqualityP
370 <|> try relationalBooleanExpr
373relationalBooleanExpr :: Parser RestrictionPredicateExpr
374relationalBooleanExpr = do
375 relexpr <- relExpr
376 return $ RelationalExprPredicate relexpr
378restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
379restrictionAttributeEqualityP = do
380 attributeName <- identifier
381 reservedOp "="
382 atom <- stringAtomP <|> intAtomP
383 return $ AttributeEqualityPredicate attributeName atom
385quotedChar = noneOf "\""
386 <|> try (string "\"\"" >> return '"')
388stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
390intAtomP = do
391 intstr <- many digit
392 return $ IntAtom (read intstr)