git.iko.soy/project-m36
on fbfd20c help sign in
project-m36/TutorialDInterpreter.hs
299 lines 9.0 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 <- identifier
93 reservedOp ":="
94 expr <- relExpr
95 return $ Assign relVarName expr
97renameClause = do
98 oldAttr <- identifier
99 reservedOp "as"
100 newAttr <- identifier
101 return $ (oldAttr, newAttr)
103renameP :: Parser (RelationalExpr -> RelationalExpr)
104renameP = do
105 reservedOp "rename"
106 (oldAttr, newAttr) <- braces renameClause
107 return $ Rename oldAttr newAttr
109groupClause = do
110 attrs <- braces attributeList
111 reservedOp "as"
112 newAttrName <- identifier
113 return $ (attrs, newAttrName)
115groupP :: Parser (RelationalExpr -> RelationalExpr)
116groupP = do
117 reservedOp "group"
118 (groupAttrList, groupAttrName) <- parens groupClause
119 return $ Group (S.fromList groupAttrList) groupAttrName
121--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.
122ungroupP :: Parser (RelationalExpr -> RelationalExpr)
123ungroupP = do
124 reservedOp "ungroup"
125 rvaAttrName <- identifier
126 return $ Ungroup rvaAttrName
128relOperators = [
129 [Postfix projectOp],
130 [Postfix renameP],
131 [Postfix groupP],
132 [Postfix ungroupP],
133 [Infix (reservedOp "join" >> return Join) AssocLeft],
134 [Infix (reservedOp "union" >> return Union) AssocLeft]
135 ]
137relExpr :: Parser RelationalExpr
138relExpr = buildExpressionParser relOperators relTerm
140databaseExpr :: Parser DatabaseExpr
141databaseExpr = insertP
142 <|> deleteP
143 <|> updateP
144 <|> constraintP
145 <|> try defineP
146 <|> try assignP
148multipleDatabaseExpr :: Parser DatabaseExpr
149multipleDatabaseExpr = do
150 exprs <- sepBy1 databaseExpr semi
151 return $ MultipleExpr exprs
153insertP :: Parser DatabaseExpr
154insertP = do
155 reservedOp "insert"
156 relvar <- identifier
157 expr <- relExpr
158 return $ Insert relvar expr
160defineP :: Parser DatabaseExpr
161defineP = do
162 relVarName <- identifier
163 reservedOp "::"
164 attributes <- makeAttributes
165 return $ Define relVarName attributes
167deleteP :: Parser DatabaseExpr
168deleteP = do
169 reservedOp "delete"
170 relVarName <- identifier
171 return $ Delete relVarName
173updateP :: Parser DatabaseExpr
174updateP = do
175 reservedOp "update"
176 relVarName <- identifier
177 -- where clause
178 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
179 return $ Update relVarName attributeAssignments
181constraintP :: Parser DatabaseExpr
182constraintP = do
183 reservedOp "constraint"
184 constraintName <- identifier
185 subset <- relExpr
186 reservedOp "in"
187 superset <- relExpr
188 return $ AddInclusionDependency (InclusionDependency constraintName subset superset)
190attributeAssignment :: Parser (String, RelationalExpr)
191attributeAssignment = do
192 attrName <- identifier
193 reservedOp ":="
194 relExpr <- relExpr
195 return $ (attrName, relExpr)
197parseString :: String -> Either RelationalError DatabaseExpr
198parseString str = case parse multipleDatabaseExpr "" str of
199 Left err -> Left $ ParseError (show err)
200 Right r -> Right r
202data TutorialDOperator where
203 ShowRelation :: RelationalExpr -> TutorialDOperator
204 ShowRelationVariableType :: String -> TutorialDOperator
205 ShowConstraint :: String -> TutorialDOperator
206 deriving (Show)
208typeP :: Parser TutorialDOperator
209typeP = do
210 reservedOp ":t"
211 relVarName <- identifier
212 return $ ShowRelationVariableType relVarName
214showRelP :: Parser TutorialDOperator
215showRelP = do
216 reservedOp ":s"
217 expr <- relExpr
218 return $ ShowRelation expr
220showConstraintsP :: Parser TutorialDOperator
221showConstraintsP = do
222 reservedOp ":c"
223 constraintName <- option "" identifier
224 return $ ShowConstraint constraintName
226interpreterOps :: Parser TutorialDOperator
227interpreterOps = typeP
228 <|> showRelP
229 <|> showConstraintsP
231showRelationAttributes :: Relation -> String
232showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
233 where
234 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
235 Just t -> show t
236 Nothing -> "unknown"
237 attrs = values (attributes rel)
238 values m = map snd (M.toAscList m)
240evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String
241evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName (relationVariables context) of
242 Just rel -> showRelationAttributes rel
243 Nothing -> relVarName ++ " not defined"
245evalTutorialDOp context (ShowRelation expr) = do
246 case runState (evalRelationalExpr expr) context of
247 (Left err, _) -> show err
248 (Right rel, _) -> showRelation rel
250evalTutorialDOp context (ShowConstraint name) = do
251 show filteredDeps
252 where
253 deps = inclusionDependencies context
254 filteredDeps = case name of
255 "" -> deps
256 name -> HS.filter (\(InclusionDependency n _ _) -> n == name) deps
258example1 = "relA {a,b, c}"
259example2 = "relA join relB"
260example3 = "relA join relB {x,y,z}"
261example4 = "(relA) {x,y,z}"
262example5 = "relA union relB"
263example6 = "rv1 := true"
264example7 = "rv1 := relA union relB"
265example8 = "relA := true; relB := false"
266example9 = "relA := relation { SNO CHAR }"
268interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
269interpret context tutdstring = case parseString tutdstring of
270 Left err -> (Just err, context)
271 Right parsed -> runState (evalContextExpr parsed) context
273-- for interpreter-specific operations
274interpretOps :: DatabaseContext -> String -> Maybe String
275interpretOps context instring = case parse interpreterOps "" instring of
276 Left err -> Nothing
277 Right ops -> Just $ evalTutorialDOp context ops
279reprLoop :: DatabaseContext -> IO ()
280reprLoop context = do
281 maybeLine <- readline "TutorialD: "
282 case maybeLine of
283 Nothing -> return ()
284 Just line -> do
285 addHistory line
287 case interpretOps context line of
288 Just out -> do
289 putStrLn out
290 reprLoop context
291 Nothing -> return ()
293 let (value, contextup) = interpret context line
294 case value of
295 Nothing -> reprLoop contextup
296 (Just err) -> do
297 putStrLn $ show err
298 reprLoop context