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