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