git.iko.soy/project-m36
on 5cc025d help sign in
project-m36/TutorialDInterpreter.hs
144 lines 4.1 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"],
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 = braces (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 <- 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
95relOperators = [
96 [Postfix projectOp],
97 [Postfix renameP],
98 [Infix (reservedOp "join" >> return Join) AssocLeft],
99 [Infix (reservedOp "union" >> return Union) AssocLeft],
100 [Prefix (try assignP)]
101 ]
103relExpr :: Parser RelationalExpr
104relExpr = buildExpressionParser relOperators relTerm
106multipleRelExpr :: Parser RelationalExpr
107multipleRelExpr = do
108 exprs <- sepBy1 relExpr semi
109 return $ MultipleExpr exprs
111parseString :: String -> RelationalExpr
112parseString str = case parse multipleRelExpr "" str of
113 Left err -> error $ show err
114 Right r -> r
116example1 = "relA {a,b, c}"
117example2 = "relA join relB"
118example3 = "relA join relB {x,y,z}"
119example4 = "(relA) {x,y,z}"
120example5 = "relA union relB"
121example6 = "rv1 := true"
122example7 = "rv1 := relA union relB"
123example8 = "relA := true; relB := false"
124example9 = "relA := relation { SNO CHAR }"
126interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)
127interpret context tutdstring = runState (eval (parseString tutdstring)) context
129reprLoop :: RelVarContext -> IO ()
130reprLoop context = do
131 maybeLine <- readline "TutorialD: "
132 case maybeLine of
133 Nothing -> return ()
134 Just line -> do
135 addHistory line
136 let (value, contextup) = interpret context line
137 case value of
138 (Right rel) -> do
139 putStrLn $ showRelation rel
140 reprLoop contextup
141 (Left err) -> do
142 putStrLn $ show err
143 reprLoop context