git.iko.soy/project-m36
on 18f736a help sign in
project-m36/src/bin/TutorialD/Interpreter/RelationalExpr.hs
261 lines 9.8 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 = do
70 attrs <- braces attributeListP
71 pure $ Project attrs
73renameClauseP :: Parser (T.Text, T.Text)
74renameClauseP = do
75 oldAttr <- identifier
76 reservedOp "as"
77 newAttr <- identifier
78 pure (oldAttr, newAttr)
80renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)
81renameP = do
82 reservedOp "rename"
83 renameList <- braces (sepBy renameClauseP comma)
84 case renameList of
85 [] -> pure (Restrict TruePredicate) --no-op when rename list is empty
86 renames ->
87 pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames
89whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
90whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)
92groupClauseP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a, T.Text)
93groupClauseP = do
94 attrs <- braces attributeListP
95 reservedOp "as"
96 newAttrName <- identifier
97 pure (attrs, newAttrName)
99groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
100groupP = do
101 reservedOp "group"
102 (groupAttrList, groupAttrName) <- parens groupClauseP
103 pure $ Group groupAttrList groupAttrName
105--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.
106ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)
107ungroupP = do
108 reservedOp "ungroup"
109 rvaAttrName <- identifier
110 pure $ Ungroup rvaAttrName
112extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
113extendP = do
114 reservedOp ":"
115 tupleExpr <- braces extendTupleExpressionP
116 return $ Extend tupleExpr
118semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)
119semijoinP = do
120 reservedOp "semijoin" <|> reservedOp "matching"
121 pure (\exprA exprB ->
122 Project (RelationalExprAttributeNames exprA) (Join exprA exprB))
124antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a)
125antijoinP = do
126 reservedOp "not matching" <|> reservedOp "antijoin"
127 pure (\exprA exprB ->
128 Difference exprA (
129 Project (RelationalExprAttributeNames exprA) (Join exprA exprB)))
131relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]]
132relOperators = [
133 [Postfix projectP],
134 [Postfix renameP],
135 [Postfix whereClauseP],
136 [Postfix groupP],
137 [Postfix ungroupP],
138 [InfixL (reservedOp "join" >> return Join)],
139 [InfixL semijoinP],
140 [InfixL antijoinP],
141 [InfixL (reservedOp "union" >> return Union)],
142 [InfixL (reservedOp "minus" >> return Difference)],
143 [InfixN (reservedOp "=" >> return Equals)],
144 [Postfix extendP]
145 ]
147relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
148relExprP = makeExprParser relTerm relOperators
150relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
151relVarP = RelationVariable <$> identifier <*> parseMarkerP
153relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
154relTerm = parens relExprP
155 <|> makeRelationP
156 <|> relVarP
158restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
159restrictionPredicateP = makeExprParser predicateTerm predicateOperators
160 where
161 predicateOperators = [
162 [Prefix (reservedOp "not" >> return NotPredicate)],
163 [InfixL (reservedOp "and" >> return AndPredicate)],
164 [InfixL (reservedOp "or" >> return OrPredicate)]
165 ]
166 predicateTerm = try (parens restrictionPredicateP)
167 <|> try restrictionAtomExprP
168 <|> try restrictionAttributeEqualityP
169 <|> relationalBooleanExprP
171relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
172relationalBooleanExprP = do
173 relexpr <- parens relExprP <|> relTerm
174 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase
175 return $ RelationalExprPredicate relexpr
177restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
178restrictionAttributeEqualityP = do
179 attributeName <- identifier
180 reservedOp "="
181 atomexpr <- atomExprP
182 return $ AttributeEqualityPredicate attributeName atomexpr
184restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"
185restrictionAtomExprP = do
186 _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar
187 (try (char 't') >> pure TruePredicate) <|> (try (char 'f') >> pure (NotPredicate TruePredicate)) <|> AtomExprPredicate <$> atomExprP
189multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a]
190multiTupleExpressionP = sepBy extendTupleExpressionP comma
192extendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
193extendTupleExpressionP = attributeExtendTupleExpressionP
195attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
196attributeExtendTupleExpressionP = do
197 newAttr <- identifier
198 reservedOp ":="
199 atom <- atomExprP
200 return $ AttributeExtendTupleExpr newAttr atom
202atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
203atomExprP = consumeAtomExprP True
205consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
206consumeAtomExprP consume = try functionAtomExprP <|>
207 try (parens (constructedAtomExprP True)) <|>
208 constructedAtomExprP consume <|>
209 attributeAtomExprP <|>
210 nakedAtomExprP <|>
211 relationalAtomExprP
213attributeAtomExprP :: Parser (AtomExprBase a)
214attributeAtomExprP = do
215 _ <- string "@"
216 attrName <- identifier
217 return $ AttributeAtomExpr attrName
219nakedAtomExprP :: Parser (AtomExprBase a)
220nakedAtomExprP = NakedAtomExpr <$> atomP
222constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
223constructedAtomExprP consume = do
224 dConsName <- capitalizedIdentifier
225 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []
226 marker <- parseMarkerP
227 pure $ ConstructedAtomExpr dConsName dConsArgs marker
229-- used only for primitive type parsing ?
230atomP :: Parser Atom
231atomP = stringAtomP <|>
232 doubleAtomP <|>
233 integerAtomP <|>
234 boolAtomP
236functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
237functionAtomExprP = do
238 funcName <- identifier
239 argList <- parens (sepBy atomExprP comma)
240 marker <- parseMarkerP
241 return $ FunctionAtomExpr funcName argList marker
243relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
244relationalAtomExprP = RelationAtomExpr <$> relExprP
246stringAtomP :: Parser Atom
247stringAtomP = TextAtom <$> quotedString
249doubleAtomP :: Parser Atom
250doubleAtomP = DoubleAtom <$> try float
252integerAtomP :: Parser Atom
253integerAtomP = IntegerAtom <$> integer
255boolAtomP :: Parser Atom
256boolAtomP = do
257 val <- char 't' <|> char 'f'
258 return $ BoolAtom (val == 't')
260relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
261relationAtomExprP = RelationAtomExpr <$> makeRelationP