git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/bin/TutorialD/Interpreter/RelationalExpr.hs
250 lines 9.4 kB history raw
1module TutorialD.Interpreter.RelationalExpr where
2import Text.Megaparsec
3import Text.Megaparsec.Expr
4import ProjectM36.Base
5import TutorialD.Interpreter.Base
6import TutorialD.Interpreter.Types
7import qualified Data.Text as T
8import qualified Data.Set as S
9import qualified Data.Map as M
10import Data.List (sort)
11import ProjectM36.MiscUtils
13--used in projection
14attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)
15attributeListP =
16 (reservedOp "all but" >>
17 InvertedAttributeNames . S.fromList <$> sepBy identifier comma) <|>
18 (reservedOp "all from" >>
19 RelationalExprAttributeNames <$> relExprP) <|>
20 (AttributeNames . S.fromList <$> sepBy identifier comma)
22makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
23makeRelationP = do
24 reserved "relation"
25 attrExprs <- try (fmap Just makeAttributeExprsP) <|> pure Nothing
26 tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []
27 pure $ MakeRelationFromExprs attrExprs tupleExprs
30--abstract data type parser- in this context, the type constructor must not include any type arguments
31--Either Text Int
32adTypeConstructorP :: Parser TypeConstructor
33adTypeConstructorP = do
34 tConsName <- capitalizedIdentifier
35 tConsArgs <- many typeConstructorP
36 pure $ ADTypeConstructor tConsName tConsArgs
38tupleExprP :: RelationalMarkerExpr a => Parser (TupleExprBase a)
39tupleExprP = do
40 reservedOp "tuple"
41 attrAssocs <- braces (sepBy tupleAtomExprP comma)
42 --detect duplicate attribute names
43 let dupAttrNames = dupes (sort (map fst attrAssocs))
44 if not (null dupAttrNames) then
45 fail ("Attribute names duplicated: " ++ show dupAttrNames)
46 else
47 pure (TupleExpr (M.fromList attrAssocs))
49tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)
50tupleAtomExprP = do
51 attributeName <- identifier
52 atomExpr <- atomExprP
53 pure (attributeName, atomExpr)
55projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
56projectP = Project <$> braces attributeListP
58renameClauseP :: Parser (T.Text, T.Text)
59renameClauseP = do
60 oldAttr <- identifier
61 reservedOp "as"
62 newAttr <- identifier
63 pure (oldAttr, newAttr)
65renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)
66renameP = do
67 reservedOp "rename"
68 renameList <- braces (sepBy renameClauseP comma)
69 case renameList of
70 [] -> pure (Restrict TruePredicate) --no-op when rename list is empty
71 renames ->
72 pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames
74whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
75whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)
77groupClauseP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a, T.Text)
78groupClauseP = do
79 attrs <- braces attributeListP
80 reservedOp "as"
81 newAttrName <- identifier
82 pure (attrs, newAttrName)
84groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
85groupP = do
86 reservedOp "group"
87 (groupAttrList, groupAttrName) <- parens groupClauseP
88 pure $ Group groupAttrList groupAttrName
90--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.
91ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)
92ungroupP = do
93 reservedOp "ungroup"
94 Ungroup <$> identifier
96extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
97extendP = do
98 reservedOp ":"
99 Extend <$> braces extendTupleExpressionP
101semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)
102semijoinP = do
103 reservedOp "semijoin" <|> reservedOp "matching"
104 pure (\exprA exprB ->
105 Project (RelationalExprAttributeNames exprA) (Join exprA exprB))
107antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)
108antijoinP = do
109 reservedOp "not matching" <|> reservedOp "antijoin"
110 pure (\exprA exprB ->
111 Difference exprA (
112 Project (RelationalExprAttributeNames exprA) (Join exprA exprB)))
114relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]]
115relOperators = [
116 [Postfix projectP],
117 [Postfix renameP],
118 [Postfix whereClauseP],
119 [Postfix groupP],
120 [Postfix ungroupP],
121 [InfixL (reservedOp "join" >> return Join)],
122 [InfixL semijoinP],
123 [InfixL antijoinP],
124 [InfixL (reservedOp "union" >> return Union)],
125 [InfixL (reservedOp "minus" >> return Difference)],
126 [InfixN (reservedOp "=" >> return Equals)],
127 [Postfix extendP]
128 ]
130relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
131relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators
133relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
134relVarP = RelationVariable <$> identifier <*> parseMarkerP
136relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
137relTerm = parens relExprP
138 <|> makeRelationP
139 <|> relVarP
141restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
142restrictionPredicateP = makeExprParser predicateTerm predicateOperators
143 where
144 predicateOperators = [
145 [Prefix (reservedOp "not" >> return NotPredicate)],
146 [InfixL (reservedOp "and" >> return AndPredicate)],
147 [InfixL (reservedOp "or" >> return OrPredicate)]
148 ]
149 predicateTerm = try (parens restrictionPredicateP)
150 <|> try restrictionAtomExprP
151 <|> try restrictionAttributeEqualityP
152 <|> relationalBooleanExprP
154relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
155relationalBooleanExprP =
156 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase
157 RelationalExprPredicate <$> (parens relExprP <|> relTerm)
159restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
160restrictionAttributeEqualityP = do
161 attributeName <- identifier
162 reservedOp "="
163 AttributeEqualityPredicate attributeName <$> atomExprP
165restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"
166restrictionAtomExprP = do
167 _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar
168 (try (char 't') >> pure TruePredicate) <|> (try (char 'f') >> pure (NotPredicate TruePredicate)) <|> AtomExprPredicate <$> atomExprP
170multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a]
171multiTupleExpressionP = sepBy extendTupleExpressionP comma
173extendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
174extendTupleExpressionP = attributeExtendTupleExpressionP
176attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
177attributeExtendTupleExpressionP = do
178 newAttr <- identifier
179 reservedOp ":="
180 AttributeExtendTupleExpr newAttr <$> atomExprP
182atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
183atomExprP = consumeAtomExprP True
185consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
186consumeAtomExprP consume = try functionAtomExprP <|>
187 try (parens (constructedAtomExprP True)) <|>
188 constructedAtomExprP consume <|>
189 attributeAtomExprP <|>
190 nakedAtomExprP <|>
191 relationalAtomExprP
193attributeAtomExprP :: Parser (AtomExprBase a)
194attributeAtomExprP = do
195 _ <- string "@"
196 AttributeAtomExpr <$> identifier
198nakedAtomExprP :: Parser (AtomExprBase a)
199nakedAtomExprP = NakedAtomExpr <$> atomP
201constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
202constructedAtomExprP consume = do
203 dConsName <- capitalizedIdentifier
204 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []
205 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP
207-- used only for primitive type parsing ?
208atomP :: Parser Atom
209atomP = stringAtomP <|>
210 doubleAtomP <|>
211 integerAtomP <|>
212 boolAtomP
214functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
215functionAtomExprP =
216 FunctionAtomExpr <$> identifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP
218relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
219relationalAtomExprP = RelationAtomExpr <$> relExprP
221stringAtomP :: Parser Atom
222stringAtomP = TextAtom <$> quotedString
224doubleAtomP :: Parser Atom
225doubleAtomP = DoubleAtom <$> try float
227integerAtomP :: Parser Atom
228integerAtomP = IntegerAtom <$> integer
230boolAtomP :: Parser Atom
231boolAtomP = do
232 val <- char 't' <|> char 'f'
233 return $ BoolAtom (val == 't')
235relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
236relationAtomExprP = RelationAtomExpr <$> makeRelationP
238withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
239withMacroExprP = do
240 reservedOp "with"
241 views <- parens (sepBy1 createViewP comma)
242 With views <$> relExprP
244createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)
245createViewP = do
246 name <- identifier
247 reservedOp "as"
248 expr <- relExprP
249 pure (name, expr)