git.iko.soy/project-m36
on 6cbd8a3 help sign in
project-m36/TutorialDInterpreter.hs
341 lines 10 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialDInterpreter where
3import Relation
4import RelationType
5import RelationalError
6import RelationExpr
7import RelationTerm
8import Text.Parsec
9import Text.Parsec.String
10import Text.Parsec.Expr
11import Text.Parsec.Language
12import qualified Text.Parsec.Token as Token
13import qualified Data.Set as S
14import qualified Data.HashSet as HS
15import qualified Data.Map as M
16import qualified Data.List as L
17import Control.Applicative (liftA, (<*), (*>))
18import Control.Monad.State
19import System.Console.Readline
22lexer :: Token.TokenParser ()
23lexer = Token.makeTokenParser tutD
24 where tutD = emptyDef {
25 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
26 Token.reservedNames = [],
27 Token.identStart = letter <|> char '_',
28 Token.identLetter = alphaNum <|> char '_'}
30parens = Token.parens lexer
31reservedOp = Token.reservedOp lexer
32reserved = Token.reserved lexer
33braces = Token.braces lexer
34identifier = Token.identifier lexer
35comma = Token.comma lexer
36semi = Token.semi lexer
38--used in projection
39attributeList :: Parser [AttributeName]
40attributeList = sepBy identifier comma
42makeRelation :: Parser RelationalExpr
43makeRelation = do
44 reservedOp "relation"
45 attrs <- makeAttributes
46 return $ MakeStaticRelation attrs HS.empty
48--used in relation creation
49makeAttributes :: Parser Attributes
50makeAttributes = do
51 attrList <- braces (sepBy attributeAndType comma)
52 return $ M.fromList $ map toAttributeAssocList attrList
53 where
54 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
56attributeAndType :: Parser Attribute
57attributeAndType = do
58 attrName <- identifier
59 attrTypeName <- identifier
60 --convert type name into type
61 case tutDTypeToAtomType attrTypeName of
62 Just t -> return $ Attribute attrName t
63 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
65--convert Tutorial D type to AtomType
66tutDTypeToAtomType :: String -> Maybe AtomType
67tutDTypeToAtomType tutDType = case tutDType of
68 "char" -> Just StringAtomType
69 "int" -> Just IntAtomType
70 _ -> Nothing
72atomTypeToTutDType :: AtomType -> Maybe String
73atomTypeToTutDType atomType = case atomType of
74 StringAtomType -> Just "char"
75 IntAtomType -> Just "int"
76 --RelationAtomType rel ->
77 _ -> Nothing
79relVarP :: Parser RelationalExpr
80relVarP = liftA RelationVariable identifier
82relTerm = parens relExpr
83 <|> makeRelation
84 <|> relVarP
86projectOp = do
87 attrs <- braces attributeList
88 return $ Project (S.fromList attrs)
90assignP :: Parser DatabaseExpr
91assignP = do
92 relVarName <- try $ do
93 relVarName <- identifier
94 reservedOp ":="
95 return relVarName
96 expr <- relExpr
97 return $ Assign relVarName expr
99renameClause = do
100 oldAttr <- identifier
101 reservedOp "as"
102 newAttr <- identifier
103 return $ (oldAttr, newAttr)
105renameP :: Parser (RelationalExpr -> RelationalExpr)
106renameP = do
107 reservedOp "rename"
108 (oldAttr, newAttr) <- braces renameClause
109 return $ Rename oldAttr newAttr
111whereClauseP = do
112 reservedOp "where"
113 boolExpr <- restrictionPredicateP
114 return $ Restrict boolExpr
116groupClause = do
117 attrs <- braces attributeList
118 reservedOp "as"
119 newAttrName <- identifier
120 return $ (attrs, newAttrName)
122groupP :: Parser (RelationalExpr -> RelationalExpr)
123groupP = do
124 reservedOp "group"
125 (groupAttrList, groupAttrName) <- parens groupClause
126 return $ Group (S.fromList groupAttrList) groupAttrName
128--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.
129ungroupP :: Parser (RelationalExpr -> RelationalExpr)
130ungroupP = do
131 reservedOp "ungroup"
132 rvaAttrName <- identifier
133 return $ Ungroup rvaAttrName
135relOperators = [
136 [Postfix projectOp],
137 [Postfix renameP],
138 [Postfix whereClauseP],
139 [Postfix groupP],
140 [Postfix ungroupP],
141 [Infix (reservedOp "join" >> return Join) AssocLeft],
142 [Infix (reservedOp "union" >> return Union) AssocLeft]
143 ]
145relExpr :: Parser RelationalExpr
146relExpr = buildExpressionParser relOperators relTerm
148databaseExpr :: Parser DatabaseExpr
149databaseExpr = insertP
150 <|> deleteP
151 <|> updateP
152 <|> constraintP
153 <|> defineP
154 <|> assignP
156multipleDatabaseExpr :: Parser DatabaseExpr
157multipleDatabaseExpr = do
158 exprs <- sepBy1 databaseExpr semi
159 return $ MultipleExpr exprs
161insertP :: Parser DatabaseExpr
162insertP = do
163 reservedOp "insert"
164 relvar <- identifier
165 expr <- relExpr
166 return $ Insert relvar expr
168defineP :: Parser DatabaseExpr
169defineP = do
170 relVarName <- try $ do
171 relVarName <- identifier
172 reservedOp "::"
173 return relVarName
174 attributes <- makeAttributes
175 return $ Define relVarName attributes
177deleteP :: Parser DatabaseExpr
178deleteP = do
179 reservedOp "delete"
180 relVarName <- identifier
181 return $ Delete relVarName
183updateP :: Parser DatabaseExpr
184updateP = do
185 reservedOp "update"
186 relVarName <- identifier
187 -- where clause
188 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
189 return $ Update relVarName attributeAssignments
191constraintP :: Parser DatabaseExpr
192constraintP = do
193 reservedOp "constraint"
194 constraintName <- identifier
195 subset <- relExpr
196 reservedOp "in"
197 superset <- relExpr
198 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
200attributeAssignment :: Parser (String, RelationalExpr)
201attributeAssignment = do
202 attrName <- identifier
203 reservedOp ":="
204 relExpr <- relExpr
205 return $ (attrName, relExpr)
207parseString :: String -> Either RelationalError DatabaseExpr
208parseString str = case parse multipleDatabaseExpr "" str of
209 Left err -> Left $ ParseError (show err)
210 Right r -> Right r
212data TutorialDOperator where
213 ShowRelation :: RelationalExpr -> TutorialDOperator
214 ShowRelationType :: RelationalExpr -> TutorialDOperator
215 ShowConstraint :: String -> TutorialDOperator
216 deriving (Show)
218typeP :: Parser TutorialDOperator
219typeP = do
220 reservedOp ":t"
221 expr <- relExpr
222 return $ ShowRelationType expr
224showRelP :: Parser TutorialDOperator
225showRelP = do
226 reservedOp ":s"
227 expr <- relExpr
228 return $ ShowRelation expr
230showConstraintsP :: Parser TutorialDOperator
231showConstraintsP = do
232 reservedOp ":c"
233 constraintName <- option "" identifier
234 return $ ShowConstraint constraintName
236interpreterOps :: Parser TutorialDOperator
237interpreterOps = typeP
238 <|> showRelP
239 <|> showConstraintsP
241showRelationAttributes :: Relation -> String
242showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
243 where
244 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
245 Just t -> show t
246 Nothing -> "unknown"
247 attrs = values (attributes rel)
248 values m = map snd (M.toAscList m)
250evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String
251evalTutorialDOp context (ShowRelationType expr) = case runState (typeForRelationalExpr expr) context of
252 (Right rel, _) -> showRelationAttributes rel
253 (Left err, _) -> show err
255evalTutorialDOp context (ShowRelation expr) = do
256 case runState (evalRelationalExpr expr) context of
257 (Left err, _) -> show err
258 (Right rel, _) -> showRelation rel
260evalTutorialDOp context (ShowConstraint name) = do
261 show filteredDeps
262 where
263 deps = inclusionDependencies context
264 filteredDeps = case name of
265 "" -> deps
266 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
268example1 = "relA {a,b, c}"
269example2 = "relA join relB"
270example3 = "relA join relB {x,y,z}"
271example4 = "(relA) {x,y,z}"
272example5 = "relA union relB"
273example6 = "rv1 := true"
274example7 = "rv1 := relA union relB"
275example8 = "relA := true; relB := false"
276example9 = "relA := relation { SNO CHAR }"
278interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
279interpret context tutdstring = case parseString tutdstring of
280 Left err -> (Just err, context)
281 Right parsed -> runState (evalContextExpr parsed) context
283-- for interpreter-specific operations
284interpretOps :: DatabaseContext -> String -> Maybe String
285interpretOps context instring = case parse interpreterOps "" instring of
286 Left err -> Nothing
287 Right ops -> Just $ evalTutorialDOp context ops
289reprLoop :: DatabaseContext -> IO ()
290reprLoop context = do
291 maybeLine <- readline "TutorialD: "
292 case maybeLine of
293 Nothing -> return ()
294 Just line -> do
295 addHistory line
297 case interpretOps context line of
298 Just out -> do
299 putStrLn out
300 reprLoop context
301 Nothing -> return ()
303 let (value, contextup) = interpret context line
304 case value of
305 Nothing -> reprLoop contextup
306 (Just err) -> do
307 putStrLn $ show err
308 reprLoop context
310restrictionPredicateP :: Parser RestrictionPredicateExpr
311restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
312 where
313 predicateOperators = [
314 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
315 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
316 ]
317 predicateTerm = parens restrictionPredicateP
318 <|> try restrictionAttributeEqualityP
319 <|> relationalBooleanExpr
321relationalBooleanExpr :: Parser RestrictionPredicateExpr
322relationalBooleanExpr = do
323 relexpr <- relExpr
324 return $ RelationalExprPredicate relexpr
326restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
327restrictionAttributeEqualityP = do
328 attributeName <- identifier
329 reservedOp "="
330 atom <- stringAtomP <|> intAtomP
331 return $ AttributeEqualityPredicate attributeName atom
333quotedChar = noneOf "\""
334 <|> try (string "\"\"" >> return '"')
336stringAtomP = liftA StringAtom (string "\"" *> many quotedChar <* string "\"")
338intAtomP = do
339 intstr <- many digit
340 return $ IntAtom (read intstr)