git.iko.soy/project-m36
on master help sign in
enforce capitalization rules for relvars and attribute names to retain context-free grammar
02fd571AgentM
src/bin/TutorialD/Interpreter/Base.hs+10−14
compare with master
unifiedsplit
@@ -90,9 +90,13 @@ braces = between (symbol "{") (symbol "}")
90identifier :: Parser Text
90identifier :: Parser Text
91identifier = do
91identifier = do
92 istart <- letterChar <|> char '_'
92 istart <- letterChar <|> char '_'
93+ identifierRemainder istart
94+
95+identifierRemainder :: Char -> Parser Text
96+identifierRemainder c = do
93− irest <- many (alphaNumChar <|> char '_' <|> char '#')
97+ rest <- many (alphaNumChar <|> char '_' <|> char '#')
94 spaceConsumer
98 spaceConsumer
95− pure (pack (istart:irest))
99+ pure (pack (c:rest))
96
100
97symbol :: ParseStr -> Parser Text
101symbol :: ParseStr -> Parser Text
98#if MIN_VERSION_megaparsec(6,0,0)
102#if MIN_VERSION_megaparsec(6,0,0)
@@ -137,20 +141,12 @@ float :: Parser Double
137float = Lex.float
141float = Lex.float
138
142
139capitalizedIdentifier :: Parser Text
143capitalizedIdentifier :: Parser Text
140−capitalizedIdentifier = do
144+capitalizedIdentifier =
141− fletter <- upperChar
145+ upperChar >>= identifierRemainder
142− restOfIdentifier_ fletter
143−
144−restOfIdentifier_ :: Char -> Parser Text
145−restOfIdentifier_ fletter = do
146− rest <- option "" identifier
147− spaceConsumer
148− pure (T.cons fletter rest)
149
146
150uncapitalizedIdentifier :: Parser Text
147uncapitalizedIdentifier :: Parser Text
151−uncapitalizedIdentifier = do
148+uncapitalizedIdentifier =
152− fletter <- lowerChar
149+ lowerChar >>= identifierRemainder
153− restOfIdentifier_ fletter
154
150
155showRelationAttributes :: Attributes -> Text
151showRelationAttributes :: Attributes -> Text
156showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
152showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"
src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+14−8
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1module TutorialD.Interpreter.DatabaseContextExpr where
2module TutorialD.Interpreter.DatabaseContextExpr where
2import ProjectM36.Base
3import ProjectM36.Base
3import TutorialD.Interpreter.Base
4import TutorialD.Interpreter.Base
@@ -12,7 +13,9 @@ import ProjectM36.Error
12import qualified ProjectM36.RelationalExpression as RE
13import qualified ProjectM36.RelationalExpression as RE
13import ProjectM36.Key
14import ProjectM36.Key
14import ProjectM36.FunctionalDependency
15import ProjectM36.FunctionalDependency
16+#if __GLASGOW_HASKELL__ < 804
15import Data.Monoid
17import Data.Monoid
18+#endif
16import Data.Functor
19import Data.Functor
17
20
18--parsers which create "database expressions" which modify the database context (such as relvar assignment)
21--parsers which create "database expressions" which modify the database context (such as relvar assignment)
@@ -42,7 +45,7 @@ nothingP = spaceConsumer >> pure NoOperation
42assignP :: Parser DatabaseContextExpr
45assignP :: Parser DatabaseContextExpr
43assignP = do
46assignP = do
44 relVarName <- try $ do
47 relVarName <- try $ do
45− relVarName <- identifier
48+ relVarName <- relVarNameP
46 reservedOp ":="
49 reservedOp ":="
47 return relVarName
50 return relVarName
48 Assign relVarName <$> relExprP
51 Assign relVarName <$> relExprP
@@ -57,13 +60,13 @@ multipleDatabaseContextExprP =
57insertP :: Parser DatabaseContextExpr
60insertP :: Parser DatabaseContextExpr
58insertP = do
61insertP = do
59 reservedOp "insert"
62 reservedOp "insert"
60− relvar <- identifier
63+ relvar <- relVarNameP
61 Insert relvar <$> relExprP
64 Insert relvar <$> relExprP
62
65
63defineP :: Parser DatabaseContextExpr
66defineP :: Parser DatabaseContextExpr
64defineP = do
67defineP = do
65 relVarName <- try $ do
68 relVarName <- try $ do
66− relVarName <- identifier
69+ relVarName <- relVarNameP
67 reservedOp "::"
70 reservedOp "::"
68 return relVarName
71 return relVarName
69 Define relVarName <$> makeAttributeExprsP
72 Define relVarName <$> makeAttributeExprsP
@@ -71,17 +74,17 @@ defineP = do
71undefineP :: Parser DatabaseContextExpr
74undefineP :: Parser DatabaseContextExpr
72undefineP = do
75undefineP = do
73 reservedOp "undefine"
76 reservedOp "undefine"
74− Undefine <$> identifier
77+ Undefine <$> relVarNameP
75
78
76deleteP :: Parser DatabaseContextExpr
79deleteP :: Parser DatabaseContextExpr
77deleteP = do
80deleteP = do
78 reservedOp "delete"
81 reservedOp "delete"
79− Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)
82+ Delete <$> relVarNameP <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)
80
83
81updateP :: Parser DatabaseContextExpr
84updateP :: Parser DatabaseContextExpr
82updateP = do
85updateP = do
83 reservedOp "update"
86 reservedOp "update"
84− relVarName <- identifier
87+ relVarName <- relVarNameP
85 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
88 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)
86 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
89 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)
87 return $ Update relVarName attributeAssignments predicate
90 return $ Update relVarName attributeAssignments predicate
@@ -164,7 +167,7 @@ addTypeConstructorP = do
164removeTypeConstructorP :: Parser DatabaseContextExpr
167removeTypeConstructorP :: Parser DatabaseContextExpr
165removeTypeConstructorP = do
168removeTypeConstructorP = do
166 reserved "undata"
169 reserved "undata"
167− RemoveTypeConstructor <$> identifier
170+ RemoveTypeConstructor <$> typeConstructorNameP
168
171
169removeAtomFunctionP :: Parser DatabaseContextExpr
172removeAtomFunctionP :: Parser DatabaseContextExpr
170removeAtomFunctionP = do
173removeAtomFunctionP = do
@@ -176,10 +179,13 @@ removeDatabaseContextFunctionP = do
176 reserved "removedatabasecontextfunction"
179 reserved "removedatabasecontextfunction"
177 RemoveDatabaseContextFunction <$> quotedString
180 RemoveDatabaseContextFunction <$> quotedString
178
181
182+functionNameP :: Parser AtomFunctionName
183+functionNameP = uncapitalizedIdentifier
184+
179executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
185executeDatabaseContextFunctionP :: Parser DatabaseContextExpr
180executeDatabaseContextFunctionP = do
186executeDatabaseContextFunctionP = do
181 reserved "execute"
187 reserved "execute"
182− funcName <- identifier
188+ funcName <- functionNameP
183 args <- parens (sepBy atomExprP comma)
189 args <- parens (sepBy atomExprP comma)
184 pure (ExecuteDatabaseContextFunction funcName args)
190 pure (ExecuteDatabaseContextFunction funcName args)
185
191
src/bin/TutorialD/Interpreter/RelationalExpr.hs+21−14
@@ -14,10 +14,10 @@ import ProjectM36.MiscUtils
14attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)
14attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)
15attributeListP =
15attributeListP =
16 (reservedOp "all but" >>
16 (reservedOp "all but" >>
17− InvertedAttributeNames . S.fromList <$> sepBy identifier comma) <|>
17+ InvertedAttributeNames . S.fromList <$> sepBy attributeNameP comma) <|>
18 (reservedOp "all from" >>
18 (reservedOp "all from" >>
19 RelationalExprAttributeNames <$> relExprP) <|>
19 RelationalExprAttributeNames <$> relExprP) <|>
20− (AttributeNames . S.fromList <$> sepBy identifier comma)
20+ (AttributeNames . S.fromList <$> sepBy attributeNameP comma)
21
21
22makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
22makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
23makeRelationP = do
23makeRelationP = do
@@ -31,7 +31,7 @@ makeRelationP = do
31--Either Text Int
31--Either Text Int
32adTypeConstructorP :: Parser TypeConstructor
32adTypeConstructorP :: Parser TypeConstructor
33adTypeConstructorP = do
33adTypeConstructorP = do
34− tConsName <- capitalizedIdentifier
34+ tConsName <- typeConstructorNameP
35 tConsArgs <- many typeConstructorP
35 tConsArgs <- many typeConstructorP
36 pure $ ADTypeConstructor tConsName tConsArgs
36 pure $ ADTypeConstructor tConsName tConsArgs
37
37
@@ -48,7 +48,7 @@ tupleExprP = do
48
48
49tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)
49tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)
50tupleAtomExprP = do
50tupleAtomExprP = do
51− attributeName <- identifier
51+ attributeName <- attributeNameP
52 atomExpr <- atomExprP
52 atomExpr <- atomExprP
53 pure (attributeName, atomExpr)
53 pure (attributeName, atomExpr)
54
54
@@ -57,9 +57,9 @@ projectP = Project <$> braces attributeListP
57
57
58renameClauseP :: Parser (T.Text, T.Text)
58renameClauseP :: Parser (T.Text, T.Text)
59renameClauseP = do
59renameClauseP = do
60− oldAttr <- identifier
60+ oldAttr <- attributeNameP
61 reservedOp "as"
61 reservedOp "as"
62− newAttr <- identifier
62+ newAttr <- attributeNameP
63 pure (oldAttr, newAttr)
63 pure (oldAttr, newAttr)
64
64
65renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)
65renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)
@@ -78,7 +78,7 @@ groupClauseP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a, T.Text)
78groupClauseP = do
78groupClauseP = do
79 attrs <- braces attributeListP
79 attrs <- braces attributeListP
80 reservedOp "as"
80 reservedOp "as"
81− newAttrName <- identifier
81+ newAttrName <- attributeNameP
82 pure (attrs, newAttrName)
82 pure (attrs, newAttrName)
83
83
84groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
84groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
@@ -91,7 +91,7 @@ groupP = do
91ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)
91ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)
92ungroupP = do
92ungroupP = do
93 reservedOp "ungroup"
93 reservedOp "ungroup"
94− Ungroup <$> identifier
94+ Ungroup <$> attributeNameP
95
95
96extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
96extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)
97extendP = do
97extendP = do
@@ -130,8 +130,15 @@ relOperators = [
130relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
130relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
131relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators
131relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators
132
132
133+--allow for additional characters
134+attributeNameP :: Parser AttributeName
135+attributeNameP = uncapitalizedIdentifier
136+
137+relVarNameP :: Parser RelVarName
138+relVarNameP = uncapitalizedIdentifier
139+
133relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
140relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
134−relVarP = RelationVariable <$> identifier <*> parseMarkerP
141+relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP
135
142
136relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
143relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)
137relTerm = parens relExprP
144relTerm = parens relExprP
@@ -158,7 +165,7 @@ relationalBooleanExprP =
158
165
159restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
166restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)
160restrictionAttributeEqualityP = do
167restrictionAttributeEqualityP = do
161− attributeName <- identifier
168+ attributeName <- attributeNameP
162 reservedOp "="
169 reservedOp "="
163 AttributeEqualityPredicate attributeName <$> atomExprP
170 AttributeEqualityPredicate attributeName <$> atomExprP
164
171
@@ -175,7 +182,7 @@ extendTupleExpressionP = attributeExtendTupleExpressionP
175
182
176attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
183attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)
177attributeExtendTupleExpressionP = do
184attributeExtendTupleExpressionP = do
178− newAttr <- identifier
185+ newAttr <- attributeNameP
179 reservedOp ":="
186 reservedOp ":="
180 AttributeExtendTupleExpr newAttr <$> atomExprP
187 AttributeExtendTupleExpr newAttr <$> atomExprP
181
188
@@ -193,14 +200,14 @@ consumeAtomExprP consume = try functionAtomExprP <|>
193attributeAtomExprP :: Parser (AtomExprBase a)
200attributeAtomExprP :: Parser (AtomExprBase a)
194attributeAtomExprP = do
201attributeAtomExprP = do
195 _ <- string "@"
202 _ <- string "@"
196− AttributeAtomExpr <$> identifier
203+ AttributeAtomExpr <$> attributeNameP
197
204
198nakedAtomExprP :: Parser (AtomExprBase a)
205nakedAtomExprP :: Parser (AtomExprBase a)
199nakedAtomExprP = NakedAtomExpr <$> atomP
206nakedAtomExprP = NakedAtomExpr <$> atomP
200
207
201constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
208constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)
202constructedAtomExprP consume = do
209constructedAtomExprP consume = do
203− dConsName <- capitalizedIdentifier
210+ dConsName <- dataConstructorNameP
204 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []
211 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []
205 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP
212 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP
206
213
@@ -243,7 +250,7 @@ withMacroExprP = do
243
250
244createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)
251createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)
245createViewP = do
252createViewP = do
246− name <- identifier
253+ name <- relVarNameP
247 reservedOp "as"
254 reservedOp "as"
248 expr <- relExprP
255 expr <- relExprP
249 pure (name, expr)
256 pure (name, expr)
src/bin/TutorialD/Interpreter/Types.hs+10−4
@@ -9,18 +9,24 @@ class RelationalMarkerExpr a where
9
9
10instance RelationalMarkerExpr () where
10instance RelationalMarkerExpr () where
11 parseMarkerP = pure ()
11 parseMarkerP = pure ()
12−
12+
13+typeConstructorNameP :: Parser TypeConstructorName
14+typeConstructorNameP = capitalizedIdentifier
15+
16+dataConstructorNameP :: Parser DataConstructorName
17+dataConstructorNameP = capitalizedIdentifier
18+
13-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.
19-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.
14-- data *Either a b* = Left a | Right b
20-- data *Either a b* = Left a | Right b
15typeConstructorDefP :: Parser TypeConstructorDef
21typeConstructorDefP :: Parser TypeConstructorDef
16−typeConstructorDefP = ADTypeConstructorDef <$> capitalizedIdentifier <*> typeVarNamesP
22+typeConstructorDefP = ADTypeConstructorDef <$> typeConstructorNameP <*> typeVarNamesP
17
23
18typeVarNamesP :: Parser [TypeVarName]
24typeVarNamesP :: Parser [TypeVarName]
19typeVarNamesP = many uncapitalizedIdentifier
25typeVarNamesP = many uncapitalizedIdentifier
20
26
21-- data Either a b = *Left a* | *Right b*
27-- data Either a b = *Left a* | *Right b*
22dataConstructorDefP :: Parser DataConstructorDef
28dataConstructorDefP :: Parser DataConstructorDef
23−dataConstructorDefP = DataConstructorDef <$> capitalizedIdentifier <*> many dataConstructorDefArgP
29+dataConstructorDefP = DataConstructorDef <$> typeConstructorNameP <*> many dataConstructorDefArgP
24
30
25-- data *Either a b* = Left *a* | Right *b*
31-- data *Either a b* = Left *a* | Right *b*
26dataConstructorDefArgP :: Parser DataConstructorDefArg
32dataConstructorDefArgP :: Parser DataConstructorDefArg
@@ -47,7 +53,7 @@ typeConstructorP = relationTypeConstructorP <|>
47 monoTypeConstructorP
53 monoTypeConstructorP
48
54
49monoTypeConstructorP :: Parser TypeConstructor
55monoTypeConstructorP :: Parser TypeConstructor
50−monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>
56+monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <|>
51 TypeVariable <$> uncapitalizedIdentifier
57 TypeVariable <$> uncapitalizedIdentifier
52
58
53
59