git.iko.soy/project-m36
on af03e83 help sign in
project-m36/TutorialDInterpreter.hs
273 lines 8.2 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 <|> try defineP
145 <|> try assignP
147multipleDatabaseExpr :: Parser DatabaseExpr
148multipleDatabaseExpr = do
149 exprs <- sepBy1 databaseExpr semi
150 return $ MultipleExpr exprs
152insertP :: Parser DatabaseExpr
153insertP = do
154 reservedOp "insert"
155 relvar <- identifier
156 expr <- relExpr
157 return $ Insert relvar expr
159defineP :: Parser DatabaseExpr
160defineP = do
161 relVarName <- identifier
162 reservedOp "::"
163 attributes <- makeAttributes
164 return $ Define relVarName attributes
166deleteP :: Parser DatabaseExpr
167deleteP = do
168 reservedOp "delete"
169 relVarName <- identifier
170 return $ Delete relVarName
172updateP :: Parser DatabaseExpr
173updateP = do
174 reservedOp "update"
175 relVarName <- identifier
176 -- where clause
177 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
178 return $ Update relVarName attributeAssignments
180attributeAssignment :: Parser (String, RelationalExpr)
181attributeAssignment = do
182 attrName <- identifier
183 reservedOp ":="
184 relExpr <- relExpr
185 return $ (attrName, relExpr)
187parseString :: String -> Either RelationalError DatabaseExpr
188parseString str = case parse multipleDatabaseExpr "" str of
189 Left err -> Left $ ParseError (show err)
190 Right r -> Right r
192data TutorialDOperator where
193 ShowRelation :: RelationalExpr -> TutorialDOperator
194 ShowRelationVariableType :: String -> TutorialDOperator
195 deriving (Show)
197typeP :: Parser TutorialDOperator
198typeP = do
199 reservedOp ":t"
200 relVarName <- identifier
201 return $ ShowRelationVariableType relVarName
203showP :: Parser TutorialDOperator
204showP = do
205 reservedOp ":s"
206 expr <- relExpr
207 return $ ShowRelation expr
209interpreterOps :: Parser TutorialDOperator
210interpreterOps = typeP
211 <|> showP
213showRelationAttributes :: Relation -> String
214showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
215 where
216 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
217 Just t -> show t
218 Nothing -> "unknown"
219 attrs = values (attributes rel)
220 values m = map snd (M.toAscList m)
222evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String
223evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName (relationVariables context) of
224 Just rel -> showRelationAttributes rel
225 Nothing -> relVarName ++ " not defined"
227evalTutorialDOp context (ShowRelation expr) = do
228 case runState (evalRelationalExpr expr) context of
229 (Left err, _) -> show err
230 (Right rel, _) -> showRelation rel
232example1 = "relA {a,b, c}"
233example2 = "relA join relB"
234example3 = "relA join relB {x,y,z}"
235example4 = "(relA) {x,y,z}"
236example5 = "relA union relB"
237example6 = "rv1 := true"
238example7 = "rv1 := relA union relB"
239example8 = "relA := true; relB := false"
240example9 = "relA := relation { SNO CHAR }"
242interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
243interpret context tutdstring = case parseString tutdstring of
244 Left err -> (Just err, context)
245 Right parsed -> runState (evalContextExpr parsed) context
247-- for interpreter-specific operations
248interpretOps :: DatabaseContext -> String -> Maybe String
249interpretOps context instring = case parse interpreterOps "" instring of
250 Left err -> Nothing
251 Right ops -> Just $ evalTutorialDOp context ops
253reprLoop :: DatabaseContext -> IO ()
254reprLoop context = do
255 maybeLine <- readline "TutorialD: "
256 case maybeLine of
257 Nothing -> return ()
258 Just line -> do
259 addHistory line
261 case interpretOps context line of
262 Just out -> do
263 putStrLn out
264 reprLoop context
265 Nothing -> return ()
267 let (value, contextup) = interpret context line
268 case value of
269 Nothing -> reprLoop contextup
270 (Just err) -> do
271 putStrLn $ show err
272 reprLoop context