git.iko.soy/project-m36
on b5477e2 help sign in
project-m36/TutorialDInterpreter.hs
230 lines 7.0 kB history raw
1{-# LANGUAGE GADTs #-}
2module TutorialDInterpreter where
3import Relation
4import RelationType
5import RelationalError
6import RelationExpr
7import RelationTerm
8import Text.Parsec
9import Text.Parsec.String
10import Text.Parsec.Expr
11import Text.Parsec.Language
12import qualified Text.Parsec.Token as Token
13import qualified Data.Set as S
14import qualified Data.HashSet as HS
15import qualified Data.Map as M
16import qualified Data.List as L
17import Control.Applicative (liftA)
18import Control.Monad.State
19import System.Console.Readline
21lexer :: Token.TokenParser ()
22lexer = Token.makeTokenParser tutD
23 where tutD = emptyDef {
24 Token.reservedOpNames = ["join", "where", "union", "group", "ungroup"],
25 Token.reservedNames = [],
26 Token.identStart = letter,
27 Token.identLetter = alphaNum}
29parens = Token.parens lexer
30reservedOp = Token.reservedOp lexer
31reserved = Token.reserved lexer
32braces = Token.braces lexer
33identifier = Token.identifier lexer
34comma = Token.comma lexer
35semi = Token.semi lexer
37--used in projection
38attributeList :: Parser [AttributeName]
39attributeList = sepBy identifier comma
41makeRelation :: Parser RelationalExpr
42makeRelation = do
43 reservedOp "relation"
44 attrs <- makeAttributes
45 return $ MakeStaticRelation attrs HS.empty
47--used in relation creation
48makeAttributes :: Parser Attributes
49makeAttributes = do
50 attrList <- braces (sepBy attributeAndType comma)
51 return $ M.fromList $ map toAttributeAssocList attrList
52 where
53 toAttributeAssocList attr@(Attribute attrName _) = (attrName, attr)
55attributeAndType :: Parser Attribute
56attributeAndType = do
57 attrName <- identifier
58 attrTypeName <- identifier
59 --convert type name into type
60 case tutDTypeToAtomType attrTypeName of
61 Just t -> return $ Attribute attrName t
62 Nothing -> fail (attrTypeName ++ " is not a valid type name.")
64--convert Tutorial D type to AtomType
65tutDTypeToAtomType :: String -> Maybe AtomType
66tutDTypeToAtomType tutDType = case tutDType of
67 "char" -> Just StringAtomType
68 "int" -> Just IntAtomType
69 _ -> Nothing
71atomTypeToTutDType :: AtomType -> Maybe String
72atomTypeToTutDType atomType = case atomType of
73 StringAtomType -> Just "char"
74 IntAtomType -> Just "int"
75 --RelationAtomType rel ->
76 _ -> Nothing
78relVarP :: Parser RelationalExpr
79relVarP = liftA RelationVariable identifier
81relTerm = parens relExpr
82 <|> makeRelation
83 <|> (try defineP)
84 <|> relVarP
86projectOp = do
87 attrs <- braces attributeList
88 return $ Project (S.fromList attrs)
90assignP = do
91 relVarName <- identifier
92 reservedOp ":="
93 return $ Assign relVarName
95renameClause = do
96 oldAttr <- identifier
97 reservedOp "as"
98 newAttr <- identifier
99 return $ (oldAttr, newAttr)
101renameP :: Parser (RelationalExpr -> RelationalExpr)
102renameP = do
103 reservedOp "rename"
104 (oldAttr, newAttr) <- braces renameClause
105 return $ Rename oldAttr newAttr
107groupClause = do
108 attrs <- braces attributeList
109 reservedOp "as"
110 newAttrName <- identifier
111 return $ (attrs, newAttrName)
113groupP :: Parser (RelationalExpr -> RelationalExpr)
114groupP = do
115 reservedOp "group"
116 (groupAttrList, groupAttrName) <- parens groupClause
117 return $ Group (S.fromList groupAttrList) groupAttrName
119--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.
120ungroupP :: Parser (RelationalExpr -> RelationalExpr)
121ungroupP = do
122 reservedOp "ungroup"
123 rvaAttrName <- identifier
124 return $ Ungroup rvaAttrName
126insertP :: Parser (RelationalExpr -> RelationalExpr)
127insertP = do
128 reservedOp "insert"
129 relvar <- identifier
130 return $ Insert relvar
132defineP :: Parser RelationalExpr
133defineP = do
134 relVarName <- identifier
135 reservedOp "::"
136 attributes <- makeAttributes
137 return $ Define relVarName attributes
139relOperators = [
140 [Postfix projectOp],
141 [Postfix renameP],
142 [Postfix groupP],
143 [Postfix ungroupP],
144 [Infix (reservedOp "join" >> return Join) AssocLeft],
145 [Infix (reservedOp "union" >> return Union) AssocLeft],
146 [Prefix insertP],
148 [Prefix (try assignP)]
149 ]
151relExpr :: Parser RelationalExpr
152relExpr = buildExpressionParser relOperators relTerm
154multipleRelExpr :: Parser RelationalExpr
155multipleRelExpr = do
156 exprs <- sepBy1 relExpr semi
157 return $ MultipleExpr exprs
159parseString :: String -> Either RelationalError RelationalExpr
160parseString str = case parse multipleRelExpr "" str of
161 Left err -> Left $ ParseError (show err)
162 Right r -> Right r
164data TutorialDOperator where
165 ShowRelationVariableType :: String -> TutorialDOperator
167interpreterOps :: Parser TutorialDOperator
168interpreterOps = do
169 reservedOp ":t"
170 relVarName <- identifier
171 return $ ShowRelationVariableType relVarName
173showRelationAttributes :: Relation -> String
174showRelationAttributes rel = "{" ++ concat (L.intersperse ", " $ map showAttribute attrs) ++ "}"
175 where
176 showAttribute (Attribute name atomType) = name ++ " " ++ case atomTypeToTutDType atomType of
177 Just t -> show t
178 Nothing -> "unknown"
179 attrs = values (attributes rel)
180 values m = map snd (M.toAscList m)
182evalTutorialDOp :: RelVarContext -> TutorialDOperator -> String
183evalTutorialDOp context (ShowRelationVariableType relVarName) = case M.lookup relVarName context of
184 Just rel -> showRelationAttributes rel
185 Nothing -> relVarName ++ " not defined"
187example1 = "relA {a,b, c}"
188example2 = "relA join relB"
189example3 = "relA join relB {x,y,z}"
190example4 = "(relA) {x,y,z}"
191example5 = "relA union relB"
192example6 = "rv1 := true"
193example7 = "rv1 := relA union relB"
194example8 = "relA := true; relB := false"
195example9 = "relA := relation { SNO CHAR }"
197interpret :: RelVarContext -> String -> (Either RelationalError Relation, RelVarContext)
198interpret context tutdstring = case parseString tutdstring of
199 Left err -> (Left err, context)
200 Right parsed -> runState (eval parsed) context
202-- for interpreter-specific operations
203interpretOps :: RelVarContext -> String -> Maybe String
204interpretOps context instring = case parse interpreterOps "" instring of
205 Left err -> Nothing
206 Right ops -> Just $ evalTutorialDOp context ops
208reprLoop :: RelVarContext -> IO ()
209reprLoop context = do
210 maybeLine <- readline "TutorialD: "
211 case maybeLine of
212 Nothing -> return ()
213 Just line -> do
214 addHistory line
216 case interpretOps context line of
217 Just out -> do
218 putStrLn out
219 reprLoop context
220 Nothing -> return ()
222 let (value, contextup) = interpret context line
223 case value of
224 (Right rel) -> do
225 putStrLn $ showRelation rel
226 reprLoop contextup
227 (Left err) -> do
228 putStrLn $ show err
229 reprLoop context