git.iko.soy/project-m36
on 444ab48 help sign in
project-m36/TutorialDInterpreter.hs
165 lines 4.8 kB history raw
1module TutorialDInterpreter where
2import RelationType
3import RelationExpr
4import RelationTerm
5import Text.Parsec
6import Text.Parsec.String
7import Text.Parsec.Expr
8import Text.Parsec.Language
9import qualified Text.Parsec.Token as Token
10import qualified Data.Set as S
11import qualified Data.HashSet as HS
12import qualified Data.Map as M
13import Control.Applicative (liftA)
14import Control.Monad.State
15import System.Console.Readline
17lexer :: Token.TokenParser ()
18lexer = Token.makeTokenParser tutD
19 where tutD = emptyDef {
20 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
21 Token.reservedNames = [],
22 Token.identStart = letter,
23 Token.identLetter = alphaNum}
25parens = Token.parens lexer
26reservedOp = Token.reservedOp lexer
27reserved = Token.reserved lexer
28braces = Token.braces lexer
29identifier = Token.identifier lexer
30comma = Token.comma lexer
31semi = Token.semi lexer
33--used in projection
34attributeList :: Parser [AttributeName]
35attributeList = sepBy identifier comma
37makeRelation :: Parser RelationalExpr
38makeRelation = do
39 reservedOp "relation"
40 attrs <- makeAttributes
41 return $ MakeStaticRelation attrs HS.empty
43--used in relation creation
44makeAttributes :: Parser Attributes
45makeAttributes = do
46 attrList <- braces (sepBy attributeAndType comma)
47 return $ M.fromList $ map toAttributeAssocList attrList
48 where
49 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
51attributeAndType :: Parser Attribute
52attributeAndType = do
53 attrName <- identifier
54 attrTypeName <- identifier
55 --convert type name into type
56 case tutDTypeToAtomType attrTypeName of
57 Just t -> return $ Attribute attrName t
58 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
60--convert Tutorial D type to AtomType
61tutDTypeToAtomType :: String -> Maybe AtomType
62tutDTypeToAtomType tutDType = case tutDType of
63 "char" -> Just StringAtomType
64 "int" -> Just IntAtomType
65 _ -> Nothing
67relVarP :: Parser RelationalExpr
68relVarP = liftA RelationVariable identifier
70relTerm = parens relExpr
71 <|> makeRelation
72 <|> relVarP
74projectOp = do
75 attrs <- braces attributeList
76 return $ Project (S.fromList attrs)
78assignP = do
79 relVarName <- identifier
80 reservedOp ":="
81 return $ Assign relVarName
83renameClause = do
84 oldAttr <- identifier
85 reservedOp "as"
86 newAttr <- identifier
87 return $ (oldAttr, newAttr)
89renameP :: Parser (RelationalExpr -> RelationalExpr)
90renameP = do
91 reservedOp "rename"
92 (oldAttr, newAttr) <- braces renameClause
93 return $ Rename oldAttr newAttr
95groupClause = do
96 attrs <- braces attributeList
97 reservedOp "as"
98 newAttrName <- identifier
99 return $ (attrs, newAttrName)
101groupP :: Parser (RelationalExpr -> RelationalExpr)
102groupP = do
103 reservedOp "group"
104 (groupAttrList, groupAttrName) <- parens groupClause
105 return $ Group (S.fromList groupAttrList) groupAttrName
107--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.
108ungroupP :: Parser (RelationalExpr -> RelationalExpr)
109ungroupP = do
110 reservedOp "ungroup"
111 rvaAttrName <- identifier
112 return $ Ungroup rvaAttrName
115relOperators = [
116 [Postfix projectOp],
117 [Postfix renameP],
118 [Postfix groupP],
119 [Infix (reservedOp "join" >> return Join) AssocLeft],
120 [Infix (reservedOp "union" >> return Union) AssocLeft],
121 [Prefix (try assignP)]
122 ]
124relExpr :: Parser RelationalExpr
125relExpr = buildExpressionParser relOperators relTerm
127multipleRelExpr :: Parser RelationalExpr
128multipleRelExpr = do
129 exprs <- sepBy1 relExpr semi
130 return $ MultipleExpr exprs
132parseString :: String -> RelationalExpr
133parseString str = case parse multipleRelExpr "" str of
134 Left err -> error $ show err
135 Right r -> r
137example1 = "relA {a,b, c}"
138example2 = "relA join relB"
139example3 = "relA join relB {x,y,z}"
140example4 = "(relA) {x,y,z}"
141example5 = "relA union relB"
142example6 = "rv1 := true"
143example7 = "rv1 := relA union relB"
144example8 = "relA := true; relB := false"
145example9 = "relA := relation { SNO CHAR }"
147interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)
148interpret context tutdstring = runState (eval (parseString tutdstring)) context
150reprLoop :: RelVarContext -> IO ()
151reprLoop context = do
152 maybeLine <- readline "TutorialD: "
153 case maybeLine of
154 Nothing -> return ()
155 Just line -> do
156 addHistory line
157 let (value, contextup) = interpret context line
158 case value of
159 (Right rel) -> do
160 putStrLn $ showRelation rel
161 reprLoop contextup
162 (Left err) -> do
163 putStrLn $ show err
164 reprLoop context