git.iko.soy/project-m36
on c4b7fc7 help sign in
project-m36/TutorialDInterpreter.hs
141 lines 4.0 kB history raw
1module TutorialDInterpreter where
2import RelationType
3import Relation
4import RelationExpr
5import RelationTuple
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, liftA2)
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"],
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 = braces (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 <- 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
96relOperators = [
97 [Postfix projectOp],
98 [Postfix renameP],
99 [Infix (reservedOp "join" >> return Join) AssocLeft],
100 [Infix (reservedOp "union" >> return Union) AssocLeft],
101 [Prefix (try assignP)]
102 ]
104relExpr :: Parser RelationalExpr
105relExpr = buildExpressionParser relOperators relTerm
107multipleRelExpr :: Parser RelationalExpr
108multipleRelExpr = do
109 exprs <- sepBy1 relExpr semi
110 return $ MultipleExpr exprs
112parseString :: String -> RelationalExpr
113parseString str = case parse multipleRelExpr "" str of
114 Left err -> error $ show err
115 Right r -> r
117example1 = "relA {a,b, c}"
118example2 = "relA join relB"
119example3 = "relA join relB {x,y,z}"
120example4 = "(relA) {x,y,z}"
121example5 = "relA union relB"
122example6 = "rv1 := true"
123example7 = "rv1 := relA union relB"
124example8 = "relA := true; relB := false"
125example9 = "relA := relation { SNO CHAR }"
127interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)
128interpret context tutdstring = runState (eval (parseString tutdstring)) context
130reprLoop :: RelVarContext -> IO ()
131reprLoop context = do
132 maybeLine <- readline "TutorialD: "
133 case maybeLine of
134 Nothing -> return ()
135 Just line -> do
136 addHistory line
137 case fst (interpret context line) of
138 Right rel -> putStrLn $ show rel
139 Left err -> putStrLn $ show err
140 reprLoop context