git.iko.soy/project-m36
on bda2cfc help sign in
project-m36/TutorialD/Interpreter/RelationalExpr.hs
321 lines 10 kB history raw
1module TutorialD.Interpreter.RelationalExpr where
2import Text.Parsec
3import Text.Parsec.Expr
4import ProjectM36.Base
5import Text.Parsec.String
6import TutorialD.Interpreter.Base
7import qualified Data.Text as T
8import qualified ProjectM36.Attribute as A
9import ProjectM36.TupleSet
10import ProjectM36.Tuple
11import ProjectM36.Relation
12import ProjectM36.Atom
13import qualified Data.Vector as V
14import qualified Data.Set as S
15import Data.Functor.Identity (Identity)
16import Data.Time.Format
17import Control.Applicative (liftA)
18import Data.ByteString.Base64 as B64
19import Data.Text.Encoding as TE
20import TutorialD.Interpreter.DataTypes.DateTime
21import TutorialD.Interpreter.DataTypes.Interval
23import Data.Time.Calendar (Day)
25atomTypeP :: Parser AtomType
26atomTypeP = (reserved "char" *> return stringAtomType) <|>
27 (reserved "int" *> return intAtomType) <|>
28 (reserved "datetime" *> return dateTimeAtomType) <|>
29 (reserved "date" *> return dateAtomType) <|>
30 (reserved "double" *> return doubleAtomType) <|>
31 (reserved "bool" *> return boolAtomType) <|>
32 (reserved "bytestring" *> return byteStringAtomType) <|>
33 (RelationAtomType <$> (reserved "relation" *> makeAttributesP))
35--used in projection
36attributeListP :: Parser AttributeNames
37attributeListP = do
38 but <- try (string "all but " <* whiteSpace) <|> string ""
39 let constructor = if but == "" then AttributeNames else InvertedAttributeNames
40 attrs <- sepBy identifier comma
41 return $ constructor (S.fromList (map T.pack attrs))
43makeRelationP :: Parser RelationalExpr
44makeRelationP = ExistingRelation <$> relationP
46--used in relation creation
47makeAttributesP :: Parser Attributes
48makeAttributesP = do
49 attrList <- braces (sepBy attributeAndTypeP comma)
50 return $ A.attributesFromList attrList
52attributeAndTypeP :: Parser Attribute
53attributeAndTypeP = do
54 attrName <- identifier
55 --convert type name into type
56 atomType <- atomTypeP
57 return $ Attribute (T.pack attrName) atomType
59tupleP :: Parser RelationTuple
60tupleP = do
61 reservedOp "tuple"
62 attrAssocs <- braces (sepBy tupleAtomP comma)
63 let attrs = A.attributesFromList $ map (\(attrName, atom) -> Attribute attrName (atomTypeForAtom atom)) attrAssocs
64 let atoms = V.fromList $ map snd attrAssocs
65 return $ mkRelationTuple attrs atoms
67tupleAtomP :: Parser (AttributeName, Atom)
68tupleAtomP = do
69 attributeName <- identifier
70 atom <- atomP
71 return $ (T.pack attributeName, atom)
73projectP :: Parser (RelationalExpr -> RelationalExpr)
74projectP = do
75 attrs <- braces attributeListP
76 return $ Project attrs
78renameClauseP :: Parser (String, String)
79renameClauseP = do
80 oldAttr <- identifier
81 reservedOp "as"
82 newAttr <- identifier
83 return $ (oldAttr, newAttr)
85renameP :: Parser (RelationalExpr -> RelationalExpr)
86renameP = do
87 reservedOp "rename"
88 (oldAttr, newAttr) <- braces renameClauseP
89 return $ Rename (T.pack oldAttr) (T.pack newAttr)
91whereClauseP :: Parser (RelationalExpr -> RelationalExpr)
92whereClauseP = do
93 reservedOp "where"
94 boolExpr <- restrictionPredicateP
95 return $ Restrict boolExpr
97groupClauseP :: Parser (AttributeNames, String)
98groupClauseP = do
99 attrs <- braces attributeListP
100 reservedOp "as"
101 newAttrName <- identifier
102 return $ (attrs, newAttrName)
104groupP :: Parser (RelationalExpr -> RelationalExpr)
105groupP = do
106 reservedOp "group"
107 (groupAttrList, groupAttrName) <- parens groupClauseP
108 return $ Group groupAttrList (T.pack groupAttrName)
110--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.
111ungroupP :: Parser (RelationalExpr -> RelationalExpr)
112ungroupP = do
113 reservedOp "ungroup"
114 rvaAttrName <- identifier
115 return $ Ungroup (T.pack rvaAttrName)
117extendP :: Parser (RelationalExpr -> RelationalExpr)
118extendP = do
119 reservedOp ":"
120 tupleExpr <- braces tupleExpressionP
121 return $ Extend tupleExpr
123{-
124rewrite summarize as extend as evaluate
125it turns out that summarize must be a relational expression primitive because it requires
127summarize SP per (SP{SNO}) add (sum(@QTY) as SUMQ) === ((SP rename {QTY as _}) group ({_} as x)) : {QTY:=sum(@x)}{S#,QTY}
128so, in general,
129summarize rX per (relExpr) add (func(@attr) as funcd) === ((rX rename {attr as _}) group ({_} as _)) : {QTY:=sum(@_)}{relExpr, _}
130-}
131{-
132summarizeP :: Parser (RelationalExpr -> RelationalExpr)
133summarizeP = do
134 reservedOp "per"
135 -- "summarize in Tutorial D requires the heading of the per relation to be a subset of that of the relation to be summarized"
136 perExpr <- parens relExpr
137 reservedOp "add"
138 (funcAtomExpr, newAttrName) <- parens summaryP
139 --rewrite summarize as extend
140 --return $ Summarize funcAtomExpr newAttrName perExpr
142summaryP :: Parser (AtomExpr, AttributeName)
143summaryP = do
144 expr <- atomExprP
145 reserved "as"
146 attrName <- identifier
147 return (expr, T.pack attrName)
148-}
150relOperators :: [[Operator String () Identity RelationalExpr]]
151relOperators = [
152 [Postfix projectP],
153 [Postfix renameP],
154 [Postfix whereClauseP],
155 [Postfix groupP],
156 [Postfix ungroupP],
157 [Infix (reservedOp "join" >> return Join) AssocLeft],
158 [Infix (reservedOp "union" >> return Union) AssocLeft],
159 [Infix (reservedOp "=" >> return Equals) AssocNone],
160 [Postfix extendP]
161 ]
163relExprP :: Parser RelationalExpr
164relExprP = buildExpressionParser relOperators relTerm
166relVarP :: Parser RelationalExpr
167relVarP = liftA (RelationVariable . T.pack) identifier
169relTerm :: Parser RelationalExpr
170relTerm = parens relExprP
171 <|> makeRelationP
172 <|> relVarP
174restrictionPredicateP :: Parser RestrictionPredicateExpr
175restrictionPredicateP = buildExpressionParser predicateOperators predicateTerm
176 where
177 predicateOperators = [
178 [Prefix (reservedOp "not" >> return NotPredicate)],
179 [Infix (reservedOp "and" >> return AndPredicate) AssocLeft],
180 [Infix (reservedOp "or" >> return OrPredicate) AssocLeft]
181 ]
182 predicateTerm = parens restrictionPredicateP
183 <|> try restrictionAtomExprP
184 <|> try restrictionAttributeEqualityP
185 <|> try relationalBooleanExprP
188relationalBooleanExprP :: Parser RestrictionPredicateExpr
189relationalBooleanExprP = do
190 relexpr <- relExprP
191 return $ RelationalExprPredicate relexpr
193restrictionAttributeEqualityP :: Parser RestrictionPredicateExpr
194restrictionAttributeEqualityP = do
195 attributeName <- identifier
196 reservedOp "="
197 atomexpr <- atomExprP
198 return $ AttributeEqualityPredicate (T.pack attributeName) atomexpr
200restrictionAtomExprP :: Parser RestrictionPredicateExpr --atoms which are of type "boolean"
201restrictionAtomExprP = do
202 _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar
203 AtomExprPredicate <$> atomExprP
205multiTupleExpressionP :: Parser [TupleExpr]
206multiTupleExpressionP = sepBy tupleExpressionP comma
208tupleExpressionP :: Parser TupleExpr
209tupleExpressionP = attributeTupleExpressionP
211attributeTupleExpressionP :: Parser TupleExpr
212attributeTupleExpressionP = do
213 newAttr <- identifier
214 reservedOp ":="
215 atom <- atomExprP
216 return $ AttributeTupleExpr (T.pack newAttr) atom
218atomExprP :: Parser AtomExpr
219atomExprP = try functionAtomExprP <|>
220 attributeAtomExprP <|>
221 nakedAtomExprP <|>
222 relationalAtomExprP
224attributeAtomExprP :: Parser AtomExpr
225attributeAtomExprP = do
226 _ <- string "@"
227 attrName <- identifier
228 return $ AttributeAtomExpr (T.pack attrName)
230nakedAtomExprP :: Parser AtomExpr
231nakedAtomExprP = NakedAtomExpr <$> atomP
233atomP :: Parser Atom
234atomP = dateTimeAtomP <|>
235 intervalDateTimeAtomP <|>
236 dateAtomP <|>
237 maybeTextAtomP <|>
238 maybeIntAtomP <|>
239 byteStringAtomP <|>
240 stringAtomP <|>
241 doubleAtomP <|>
242 intAtomP <|>
243 boolAtomP <|>
244 relationAtomP
246functionAtomExprP :: Parser AtomExpr
247functionAtomExprP = do
248 funcName <- identifier
249 argList <- parens (sepBy atomExprP comma)
250 return $ FunctionAtomExpr (T.pack funcName) argList
252relationalAtomExprP :: Parser AtomExpr
253relationalAtomExprP = RelationAtomExpr <$> relExprP
255stringAtomP :: Parser Atom
256stringAtomP = liftA (Atom . T.pack) quotedString
258--until polymorphic type constructors and algebraic data types are properly supported, such constructs must be unfortunately hard-coded
259maybeTextAtomP :: Parser Atom
260maybeTextAtomP = do
261 maybeText <- try $ ((Just . T.pack <$> (reserved "Just" *> quotedString)) <|>
262 (reserved "Nothing" *> return Nothing)) <* reserved "::maybe char"
263 return $ Atom maybeText
265maybeIntAtomP :: Parser Atom
266maybeIntAtomP = do
267 maybeInt <- try $ ((Just . fromIntegral <$> (reserved "Just" *> integer)) <|>
268 (reserved "Nothing" *> return Nothing)) <* reserved "::maybe int"
269 return $ Atom (maybeInt :: Maybe Int)
271dateAtomP :: Parser Atom
272dateAtomP = do
273 dateString' <- try $ do
274 dateString <- quotedString
275 reserved "::date"
276 return dateString
277 case parseTimeM False defaultTimeLocale "%Y-%m-%d" dateString' of
278 Just todaytime -> return $ Atom (todaytime :: Day)
279 Nothing -> fail "Failed to parse date"
281doubleAtomP :: Parser Atom
282doubleAtomP = Atom <$> (try float)
284intAtomP :: Parser Atom
285intAtomP = do
286 i <- integer
287 return $ Atom ((fromIntegral i) :: Int)
289boolAtomP :: Parser Atom
290boolAtomP = do
291 val <- char 't' <|> char 'f'
292 return $ Atom (val == 't')
294relationAtomP :: Parser Atom
295relationAtomP = Atom <$> relationP
297byteStringAtomP :: Parser Atom
298byteStringAtomP = do
299 byteString' <- try $ do
300 byteString <- quotedString
301 reserved "::bytestring"
302 return byteString
303 case B64.decode $ TE.encodeUtf8 (T.pack byteString') of
304 Left err -> fail err
305 Right bsVal -> return $ Atom bsVal
307--relation constructor -- no choice but to propagate relation-construction errors as parse errors. Perhaps this could be improved in the future
308relationP :: Parser Relation
309relationP = do
310 reserved "relation"
311 attrs <- (try makeAttributesP <|> return A.emptyAttributes)
312 if not (A.null attrs) then do
313 case mkRelation attrs emptyTupleSet of
314 Left err -> fail (show err)
315 Right rel -> return rel
316 else do
317 tuples <- braces (sepBy tupleP comma)
318 case mkRelationFromTuples (tupleAttributes (head tuples)) tuples of
319 Left err -> fail (show err)
320 Right rel -> return rel