git.iko.soy/project-m36
on fd05d50 help sign in
project-m36/src/bin/TutorialD/Interpreter/RelationalExpr.hs
248 lines 8.9 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 :: Parser AttributeNames
22attributeListP = do
23 but <- try (string "all but " <* spaceConsumer) <|> string ""
24 let constructor = if but == "" then AttributeNames else InvertedAttributeNames
25 attrs <- sepBy identifier comma
26 pure $ constructor (S.fromList attrs)
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
35--used in relation creation
36makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]
37makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)
39attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)
40attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP
42--abstract data type parser- in this context, the type constructor must not include any type arguments
43--Either Text Int
44adTypeConstructorP :: Parser TypeConstructor
45adTypeConstructorP = do
46 tConsName <- capitalizedIdentifier
47 tConsArgs <- many typeConstructorP
48 pure $ ADTypeConstructor tConsName tConsArgs
50tupleExprP :: RelationalMarkerExpr a => Parser (TupleExprBase a)
51tupleExprP = do
52 reservedOp "tuple"
53 attrAssocs <- braces (sepBy tupleAtomExprP comma)
54 --detect duplicate attribute names
55 let dupAttrNames = dupes (sort (map fst attrAssocs))
56 if not (null dupAttrNames) then
57 fail ("Attribute names duplicated: " ++ show dupAttrNames)
58 else
59 pure (TupleExpr (M.fromList attrAssocs))
61tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)
62tupleAtomExprP = do
63 attributeName <- identifier
64 atomExpr <- atomExprP
65 pure (attributeName, atomExpr)
67projectP :: Parser (RelationalExprBase a -> RelationalExprBase a)
68projectP = do
69 attrs <- braces attributeListP
70 pure $ Project attrs
72renameClauseP :: Parser (T.Text, T.Text)
73renameClauseP = do
74 oldAttr <- identifier
75 reservedOp "as"
76 newAttr <- identifier
77 pure (oldAttr, newAttr)
79renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)
80renameP = do
81 reservedOp "rename"
82 renameList <- braces (sepBy renameClauseP comma)
83 case renameList of
84 [] -> pure (Restrict TruePredicate) --no-op when rename list is empty
85 renames ->
86 pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames
88whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
89whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)
91groupClauseP :: Parser (AttributeNames, T.Text)
92groupClauseP = do
93 attrs <- braces attributeListP
94 reservedOp "as"
95 newAttrName <- identifier
96 pure (attrs, newAttrName)
98groupP :: Parser (RelationalExprBase a -> RelationalExprBase a)
99groupP = do
100 reservedOp "group"
101 (groupAttrList, groupAttrName) <- parens groupClauseP
102 pure $ Group groupAttrList groupAttrName
104--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.
105ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)
106ungroupP = do
107 reservedOp "ungroup"
108 rvaAttrName <- identifier
109 pure $ Ungroup rvaAttrName
111extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
112extendP = do
113 reservedOp ":"
114 tupleExpr <- braces extendTupleExpressionP
115 return $ Extend tupleExpr
117relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]]
118relOperators = [
119 [Postfix projectP],
120 [Postfix renameP],
121 [Postfix whereClauseP],
122 [Postfix groupP],
123 [Postfix ungroupP],
124 [InfixL (reservedOp "join" >> return Join)],
125 [InfixL (reservedOp "union" >> return Union)],
126 [InfixL (reservedOp "minus" >> return Difference)],
127 [InfixN (reservedOp "=" >> return Equals)],
128 [Postfix extendP]
129 ]
131relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
132relExprP = makeExprParser relTerm relOperators
134relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
135relVarP = RelationVariable <$> identifier <*> parseMarkerP
137relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
138relTerm = parens relExprP
139 <|> makeRelationP
140 <|> relVarP
142restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
143restrictionPredicateP = makeExprParser predicateTerm predicateOperators
144 where
145 predicateOperators = [
146 [Prefix (reservedOp "not" >> return NotPredicate)],
147 [InfixL (reservedOp "and" >> return AndPredicate)],
148 [InfixL (reservedOp "or" >> return OrPredicate)]
149 ]
150 predicateTerm = try (parens restrictionPredicateP)
151 <|> try restrictionAtomExprP
152 <|> try restrictionAttributeEqualityP
153 <|> try relationalBooleanExprP
156relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
157relationalBooleanExprP = do
158 relexpr <- parens relExprP <|> relTerm
159 --we can't actually detect if the type is relational boolean, so we just pass it to the next phase
160 return $ RelationalExprPredicate relexpr
162restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
163restrictionAttributeEqualityP = do
164 attributeName <- identifier
165 reservedOp "="
166 atomexpr <- atomExprP
167 return $ AttributeEqualityPredicate attributeName atomexpr
169restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"
170restrictionAtomExprP = do
171 _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar
172 AtomExprPredicate <$> atomExprP
174multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a]
175multiTupleExpressionP = sepBy extendTupleExpressionP comma
177extendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
178extendTupleExpressionP = attributeExtendTupleExpressionP
180attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
181attributeExtendTupleExpressionP = do
182 newAttr <- identifier
183 reservedOp ":="
184 atom <- atomExprP
185 return $ AttributeExtendTupleExpr newAttr atom
187atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
188atomExprP = consumeAtomExprP True
190consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
191consumeAtomExprP consume = try functionAtomExprP <|>
192 try (parens (constructedAtomExprP True)) <|>
193 constructedAtomExprP consume <|>
194 attributeAtomExprP <|>
195 nakedAtomExprP <|>
196 relationalAtomExprP
198attributeAtomExprP :: Parser (AtomExprBase a)
199attributeAtomExprP = do
200 _ <- string "@"
201 attrName <- identifier
202 return $ AttributeAtomExpr attrName
204nakedAtomExprP :: Parser (AtomExprBase a)
205nakedAtomExprP = NakedAtomExpr <$> atomP
207constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
208constructedAtomExprP consume = do
209 dConsName <- capitalizedIdentifier
210 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []
211 marker <- parseMarkerP
212 pure $ ConstructedAtomExpr dConsName dConsArgs marker
214-- used only for primitive type parsing ?
215atomP :: Parser Atom
216atomP = stringAtomP <|>
217 doubleAtomP <|>
218 intAtomP <|>
219 boolAtomP
221functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
222functionAtomExprP = do
223 funcName <- identifier
224 argList <- parens (sepBy atomExprP comma)
225 marker <- parseMarkerP
226 return $ FunctionAtomExpr funcName argList marker
228relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
229relationalAtomExprP = RelationAtomExpr <$> relExprP
231stringAtomP :: Parser Atom
232stringAtomP = TextAtom <$> quotedString
234doubleAtomP :: Parser Atom
235doubleAtomP = DoubleAtom <$> try float
237intAtomP :: Parser Atom
238intAtomP = do
239 i <- integer
240 return $ IntAtom (fromIntegral i)
242boolAtomP :: Parser Atom
243boolAtomP = do
244 val <- char 't' <|> char 'f'
245 return $ BoolAtom (val == 't')
247relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)
248relationAtomExprP = RelationAtomExpr <$> makeRelationP