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