git.iko.soy/project-m36
on 86998f1 help sign in
project-m36/TutorialDInterpreter.hs
142 lines 4.0 kB history raw
1module TutorialDInterpreter where
2import RelationType
3import Relation
4import RelationExpr
5import RelationTuple
6import RelationTerm
7import Text.Parsec
8import Text.Parsec.String
9import Text.Parsec.Expr
10import Text.Parsec.Language
11import qualified Text.Parsec.Token as Token
12import qualified Data.Set as S
13import qualified Data.HashSet as HS
14import qualified Data.Map as M
15import Control.Applicative ((<$), (<*), (*>), liftA, liftA2)
16import Control.Monad.State
17import System.Console.Readline
19lexer :: Token.TokenParser ()
20lexer = Token.makeTokenParser tutD
21 where tutD = emptyDef {
22 Token.reservedOpNames = ["join", "where", "union"],
23 Token.reservedNames = [],
24 Token.identStart = letter,
25 Token.identLetter = alphaNum}
27parens = Token.parens lexer
28reservedOp = Token.reservedOp lexer
29reserved = Token.reserved lexer
30braces = Token.braces lexer
31identifier = Token.identifier lexer
32comma = Token.comma lexer
33semi = Token.semi lexer
35--used in projection
36attributeList :: Parser [AttributeName]
37attributeList = braces (sepBy identifier comma)
39makeRelation :: Parser RelationalExpr
40makeRelation = do
41 reservedOp "relation"
42 attrs <- makeAttributes
43 return $ MakeStaticRelation attrs HS.empty
45--used in relation creation
46makeAttributes :: Parser Attributes
47makeAttributes = do
48 attrList <- braces (sepBy attributeAndType comma)
49 return $ M.fromList $ map toAttributeAssocList attrList
50 where
51 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
53attributeAndType :: Parser Attribute
54attributeAndType = do
55 attrName <- identifier
56 attrTypeName <- identifier
57 --convert type name into type
58 case tutDTypeToAtomType attrTypeName of
59 Just t -> return $ Attribute attrName t
60 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
62--convert Tutorial D type to AtomType
63tutDTypeToAtomType :: String -> Maybe AtomType
64tutDTypeToAtomType tutDType = case tutDType of
65 "char" -> Just StringAtomType
66 "int" -> Just IntAtomType
67 _ -> Nothing
69relVarP :: Parser RelationalExpr
70relVarP = liftA RelationVariable identifier
72relTerm = parens relExpr
73 <|> makeRelation
74 <|> relVarP
76projectOp = do
77 attrs <- attributeList
78 return $ Project (S.fromList attrs)
80assignP = do
81 relVarName <- identifier
82 reservedOp ":="
83 return $ Assign relVarName
85renameClause = do
86 oldAttr <- identifier
87 reservedOp "as"
88 newAttr <- identifier
89 return $ (oldAttr, newAttr)
91renameP :: Parser (RelationalExpr -> RelationalExpr)
92renameP = do
93 reservedOp "rename"
94 (oldAttr, newAttr) <- braces renameClause
95 return $ Rename oldAttr newAttr
97relOperators = [
98 [Postfix projectOp],
99 [Postfix renameP],
100 [Infix (reservedOp "join" >> return Join) AssocLeft],
101 [Infix (reservedOp "union" >> return Union) AssocLeft],
102 [Prefix (try assignP)]
103 ]
105relExpr :: Parser RelationalExpr
106relExpr = buildExpressionParser relOperators relTerm
108multipleRelExpr :: Parser RelationalExpr
109multipleRelExpr = do
110 exprs <- sepBy1 relExpr semi
111 return $ MultipleExpr exprs
113parseString :: String -> RelationalExpr
114parseString str = case parse multipleRelExpr "" str of
115 Left err -> error $ show err
116 Right r -> r
118example1 = "relA {a,b, c}"
119example2 = "relA join relB"
120example3 = "relA join relB {x,y,z}"
121example4 = "(relA) {x,y,z}"
122example5 = "relA union relB"
123example6 = "rv1 := true"
124example7 = "rv1 := relA union relB"
125example8 = "relA := true; relB := false"
126example9 = "relA := relation { SNO CHAR }"
128interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)
129interpret context tutdstring = runState (eval (parseString tutdstring)) context
131reprLoop :: RelVarContext -> IO ()
132reprLoop context = do
133 maybeLine <- readline "TutorialD: "
134 case maybeLine of
135 Nothing -> return ()
136 Just line -> do
137 addHistory line
138 case fst (interpret context line) of
139 Right rel -> putStrLn $ showRelation rel
140 Left err -> putStrLn $ show err
141 reprLoop context