git.iko.soy/project-m36
on 2e1e4d2 help sign in
project-m36/TutorialDInterpreter.hs
272 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
21lexer :: Token.TokenParser ()
22lexer = Token.makeTokenParser tutD
23 where tutD = emptyDef {
24 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
25 Token.reservedNames = [],
26 Token.identStart = letter,
27 Token.identLetter = alphaNum}
29parens = Token.parens lexer
30reservedOp = Token.reservedOp lexer
31reserved = Token.reserved lexer
32braces = Token.braces lexer
33identifier = Token.identifier lexer
34comma = Token.comma lexer
35semi = Token.semi lexer
37--used in projection
38attributeList :: Parser [AttributeName]
39attributeList = sepBy identifier comma
41makeRelation :: Parser RelationalExpr
42makeRelation = do
43 reservedOp "relation"
44 attrs <- makeAttributes
45 return $ MakeStaticRelation attrs HS.empty
47--used in relation creation
48makeAttributes :: Parser Attributes
49makeAttributes = do
50 attrList <- braces (sepBy attributeAndType comma)
51 return $ M.fromList $ map toAttributeAssocList attrList
52 where
53 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
55attributeAndType :: Parser Attribute
56attributeAndType = do
57 attrName <- identifier
58 attrTypeName <- identifier
59 --convert type name into type
60 case tutDTypeToAtomType attrTypeName of
61 Just t -> return $ Attribute attrName t
62 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
64--convert Tutorial D type to AtomType
65tutDTypeToAtomType :: String -> Maybe AtomType
66tutDTypeToAtomType tutDType = case tutDType of
67 "char" -> Just StringAtomType
68 "int" -> Just IntAtomType
69 _ -> Nothing
71atomTypeToTutDType :: AtomType -> Maybe String
72atomTypeToTutDType atomType = case atomType of
73 StringAtomType -> Just "char"
74 IntAtomType -> Just "int"
75 --RelationAtomType rel ->
76 _ -> Nothing
78relVarP :: Parser RelationalExpr
79relVarP = liftA RelationVariable identifier
81relTerm = parens relExpr
82 <|> makeRelation
83 <|> relVarP
85projectOp = do
86 attrs <- braces attributeList
87 return $ Project (S.fromList attrs)
89assignP :: Parser DatabaseExpr
90assignP = do
91 relVarName <- identifier
92 reservedOp ":="
93 expr <- relExpr
94 return $ Assign relVarName expr
96renameClause = do
97 oldAttr <- identifier
98 reservedOp "as"
99 newAttr <- identifier
100 return $ (oldAttr, newAttr)
102renameP :: Parser (RelationalExpr -> RelationalExpr)
103renameP = do
104 reservedOp "rename"
105 (oldAttr, newAttr) <- braces renameClause
106 return $ Rename oldAttr newAttr
108groupClause = do
109 attrs <- braces attributeList
110 reservedOp "as"
111 newAttrName <- identifier
112 return $ (attrs, newAttrName)
114groupP :: Parser (RelationalExpr -> RelationalExpr)
115groupP = do
116 reservedOp "group"
117 (groupAttrList, groupAttrName) <- parens groupClause
118 return $ Group (S.fromList groupAttrList) groupAttrName
120--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.
121ungroupP :: Parser (RelationalExpr -> RelationalExpr)
122ungroupP = do
123 reservedOp "ungroup"
124 rvaAttrName <- identifier
125 return $ Ungroup rvaAttrName
127relOperators = [
128 [Postfix projectOp],
129 [Postfix renameP],
130 [Postfix groupP],
131 [Postfix ungroupP],
132 [Infix (reservedOp "join" >> return Join) AssocLeft],
133 [Infix (reservedOp "union" >> return Union) AssocLeft]
134 ]
136relExpr :: Parser RelationalExpr
137relExpr = buildExpressionParser relOperators relTerm
139databaseExpr :: Parser DatabaseExpr
140databaseExpr = insertP
141 <|> deleteP
142 <|> updateP
143 <|> try defineP
144 <|> try assignP
146multipleDatabaseExpr :: Parser DatabaseExpr
147multipleDatabaseExpr = do
148 exprs <- sepBy1 databaseExpr semi
149 return $ MultipleExpr exprs
151insertP :: Parser DatabaseExpr
152insertP = do
153 reservedOp "insert"
154 relvar <- identifier
155 expr <- relExpr
156 return $ Insert relvar expr
158defineP :: Parser DatabaseExpr
159defineP = do
160 relVarName <- identifier
161 reservedOp "::"
162 attributes <- makeAttributes
163 return $ Define relVarName attributes
165deleteP :: Parser DatabaseExpr
166deleteP = do
167 reservedOp "delete"
168 relVarName <- identifier
169 return $ Delete relVarName
171updateP :: Parser DatabaseExpr
172updateP = do
173 reservedOp "update"
174 relVarName <- identifier
175 -- where clause
176 attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignment comma)
177 return $ Update relVarName attributeAssignments
179attributeAssignment :: Parser (String, RelationalExpr)
180attributeAssignment = do
181 attrName <- identifier
182 reservedOp ":="
183 relExpr <- relExpr
184 return $ (attrName, relExpr)
186parseString :: String -> Either RelationalError DatabaseExpr
187parseString str = case parse multipleDatabaseExpr "" str of
188 Left err -> Left $ ParseError (show err)
189 Right r -> Right r
191data TutorialDOperator where
192 ShowRelation :: RelationalExpr -> TutorialDOperator
193 ShowRelationVariableType :: String -> TutorialDOperator
194 deriving (Show)
196typeP :: Parser TutorialDOperator
197typeP = do
198 reservedOp ":t"
199 relVarName <- identifier
200 return $ ShowRelationVariableType relVarName
202showP :: Parser TutorialDOperator
203showP = do
204 reservedOp ":s"
205 expr <- relExpr
206 return $ ShowRelation expr
208interpreterOps :: Parser TutorialDOperator
209interpreterOps = typeP
210 <|> showP
212showRelationAttributes :: Relation -> String
213showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
214 where
215 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
216 Just t -> show t
217 Nothing -> "unknown"
218 attrs = values (attributes rel)
219 values m = map snd (M.toAscList m)
221evalTutorialDOp :: DatabaseContext -> TutorialDOperator -> String
222evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName (relationVariables context) of
223 Just rel -> showRelationAttributes rel
224 Nothing -> relVarName ++ " not defined"
226evalTutorialDOp context (ShowRelation expr) = do
227 case runState (evalRelationalExpr expr) context of
228 (Left err, _) -> show err
229 (Right rel, _) -> showRelation rel
231example1 = "relA {a,b, c}"
232example2 = "relA join relB"
233example3 = "relA join relB {x,y,z}"
234example4 = "(relA) {x,y,z}"
235example5 = "relA union relB"
236example6 = "rv1 := true"
237example7 = "rv1 := relA union relB"
238example8 = "relA := true; relB := false"
239example9 = "relA := relation { SNO CHAR }"
241interpret :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)
242interpret context tutdstring = case parseString tutdstring of
243 Left err -> (Just err, context)
244 Right parsed -> runState (evalContextExpr parsed) context
246-- for interpreter-specific operations
247interpretOps :: DatabaseContext -> String -> Maybe String
248interpretOps context instring = case parse interpreterOps "" instring of
249 Left err -> Nothing
250 Right ops -> Just $ evalTutorialDOp context ops
252reprLoop :: DatabaseContext -> IO ()
253reprLoop context = do
254 maybeLine <- readline "TutorialD: "
255 case maybeLine of
256 Nothing -> return ()
257 Just line -> do
258 addHistory line
260 case interpretOps context line of
261 Just out -> do
262 putStrLn out
263 reprLoop context
264 Nothing -> return ()
266 let (value, contextup) = interpret context line
267 case value of
268 Nothing -> reprLoop contextup
269 (Just err) -> do
270 putStrLn $ show err
271 reprLoop context