02fd571 · project-m36 · git.iko.soy

git.iko.soy/project-m36

enforce capitalization rules for relvars and attribute names to retain context-free grammar

resolves #243

commit02fd5714a944715ecf4643f6c5f70ea8a51db94f authorAgentM <agentm@themactionfaction.com> dateWed 3 Jul 2019, 23:17 (7 years ago) parentc514a08

4 files changed+55−40

compare with master

unifiedsplit

src/bin/TutorialD/Interpreter/Base.hs+10−14 src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+14−8 src/bin/TutorialD/Interpreter/RelationalExpr.hs+21−14 src/bin/TutorialD/Interpreter/Types.hs+10−4

src/bin/TutorialD/Interpreter/Base.hs+10−14

@@ -90,9 +90,13 @@ braces = between (symbol "{") (symbol "}")

9090identifier :: Parser Text

9191identifier = do

9292 istart <- letterChar <|> char '_'

93− irest <- many (alphaNumChar <|> char '_' <|> char '#')

93+ identifierRemainder istart

94+

95+identifierRemainder :: Char -> Parser Text

96+identifierRemainder c = do

97+ rest <- many (alphaNumChar <|> char '_' <|> char '#')

9498 spaceConsumer

95− pure (pack (istart:irest))

99+ pure (pack (c:rest))

96100

97101symbol :: ParseStr -> Parser Text

98102#if MIN_VERSION_megaparsec(6,0,0)

@@ -137,20 +141,12 @@ float :: Parser Double

137141float = Lex.float

138142

139143capitalizedIdentifier :: Parser Text

140−capitalizedIdentifier = do

141− fletter <- upperChar

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)

144+capitalizedIdentifier =

145+ upperChar >>= identifierRemainder

149146

150147uncapitalizedIdentifier :: Parser Text

151−uncapitalizedIdentifier = do

152− fletter <- lowerChar

153− restOfIdentifier_ fletter

148+uncapitalizedIdentifier =

149+ lowerChar >>= identifierRemainder

154150

155151showRelationAttributes :: Attributes -> Text

156152showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+14−8

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12module TutorialD.Interpreter.DatabaseContextExpr where

23import ProjectM36.Base

34import TutorialD.Interpreter.Base

@@ -12,7 +13,9 @@ import ProjectM36.Error

1213import qualified ProjectM36.RelationalExpression as RE

1314import ProjectM36.Key

1415import ProjectM36.FunctionalDependency

16+#if __GLASGOW_HASKELL__ < 804

1517import Data.Monoid

18+#endif

1619import Data.Functor

1720

1821--parsers which create "database expressions" which modify the database context (such as relvar assignment)

@@ -42,7 +45,7 @@ nothingP = spaceConsumer >> pure NoOperation

4245assignP :: Parser DatabaseContextExpr

4346assignP = do

4447 relVarName <- try $ do

45− relVarName <- identifier

48+ relVarName <- relVarNameP

4649 reservedOp ":="

4750 return relVarName

4851 Assign relVarName <$> relExprP

@@ -57,13 +60,13 @@ multipleDatabaseContextExprP =

5760insertP :: Parser DatabaseContextExpr

5861insertP = do

5962 reservedOp "insert"

60− relvar <- identifier

63+ relvar <- relVarNameP

6164 Insert relvar <$> relExprP

6265

6366defineP :: Parser DatabaseContextExpr

6467defineP = do

6568 relVarName <- try $ do

66− relVarName <- identifier

69+ relVarName <- relVarNameP

6770 reservedOp "::"

6871 return relVarName

6972 Define relVarName <$> makeAttributeExprsP

@@ -71,17 +74,17 @@ defineP = do

7174undefineP :: Parser DatabaseContextExpr

7275undefineP = do

7376 reservedOp "undefine"

74− Undefine <$> identifier

77+ Undefine <$> relVarNameP

7578

7679deleteP :: Parser DatabaseContextExpr

7780deleteP = do

7881 reservedOp "delete"

79− Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)

82+ Delete <$> relVarNameP <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP)

8083

8184updateP :: Parser DatabaseContextExpr

8285updateP = do

8386 reservedOp "update"

84− relVarName <- identifier

87+ relVarName <- relVarNameP

8588 predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)

8689 attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma)

8790 return $ Update relVarName attributeAssignments predicate

@@ -164,7 +167,7 @@ addTypeConstructorP = do

164167removeTypeConstructorP :: Parser DatabaseContextExpr

165168removeTypeConstructorP = do

166169 reserved "undata"

167− RemoveTypeConstructor <$> identifier

170+ RemoveTypeConstructor <$> typeConstructorNameP

168171

169172removeAtomFunctionP :: Parser DatabaseContextExpr

170173removeAtomFunctionP = do

@@ -176,10 +179,13 @@ removeDatabaseContextFunctionP = do

176179 reserved "removedatabasecontextfunction"

177180 RemoveDatabaseContextFunction <$> quotedString

178181

182+functionNameP :: Parser AtomFunctionName

183+functionNameP = uncapitalizedIdentifier

184+

179185executeDatabaseContextFunctionP :: Parser DatabaseContextExpr

180186executeDatabaseContextFunctionP = do

181187 reserved "execute"

182− funcName <- identifier

188+ funcName <- functionNameP

183189 args <- parens (sepBy atomExprP comma)

184190 pure (ExecuteDatabaseContextFunction funcName args)

185191

src/bin/TutorialD/Interpreter/RelationalExpr.hs+21−14

@@ -14,10 +14,10 @@ import ProjectM36.MiscUtils

1414attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a)

1515attributeListP =

1616 (reservedOp "all but" >>

17− InvertedAttributeNames . S.fromList <$> sepBy identifier comma) <|>

17+ InvertedAttributeNames . S.fromList <$> sepBy attributeNameP comma) <|>

1818 (reservedOp "all from" >>

1919 RelationalExprAttributeNames <$> relExprP) <|>

20− (AttributeNames . S.fromList <$> sepBy identifier comma)

20+ (AttributeNames . S.fromList <$> sepBy attributeNameP comma)

2121

2222makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

2323makeRelationP = do

@@ -31,7 +31,7 @@ makeRelationP = do

3131--Either Text Int

3232adTypeConstructorP :: Parser TypeConstructor

3333adTypeConstructorP = do

34− tConsName <- capitalizedIdentifier

34+ tConsName <- typeConstructorNameP

3535 tConsArgs <- many typeConstructorP

3636 pure $ ADTypeConstructor tConsName tConsArgs

3737

@@ -48,7 +48,7 @@ tupleExprP = do

4848

4949tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)

5050tupleAtomExprP = do

51− attributeName <- identifier

51+ attributeName <- attributeNameP

5252 atomExpr <- atomExprP

5353 pure (attributeName, atomExpr)

5454

@@ -57,9 +57,9 @@ projectP = Project <$> braces attributeListP

5757

5858renameClauseP :: Parser (T.Text, T.Text)

5959renameClauseP = do

60− oldAttr <- identifier

60+ oldAttr <- attributeNameP

6161 reservedOp "as"

62− newAttr <- identifier

62+ newAttr <- attributeNameP

6363 pure (oldAttr, newAttr)

6464

6565renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)

@@ -78,7 +78,7 @@ groupClauseP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a, T.Text)

7878groupClauseP = do

7979 attrs <- braces attributeListP

8080 reservedOp "as"

81− newAttrName <- identifier

81+ newAttrName <- attributeNameP

8282 pure (attrs, newAttrName)

8383

8484groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

@@ -91,7 +91,7 @@ groupP = do

9191ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)

9292ungroupP = do

9393 reservedOp "ungroup"

94− Ungroup <$> identifier

94+ Ungroup <$> attributeNameP

9595

9696extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)

9797extendP = do

@@ -130,8 +130,15 @@ relOperators = [

130130relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

131131relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators

132132

133+--allow for additional characters

134+attributeNameP :: Parser AttributeName

135+attributeNameP = uncapitalizedIdentifier

136+

137+relVarNameP :: Parser RelVarName

138+relVarNameP = uncapitalizedIdentifier

139+

133140relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

134−relVarP = RelationVariable <$> identifier <*> parseMarkerP

141+relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP

135142

136143relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)

137144relTerm = parens relExprP

@@ -158,7 +165,7 @@ relationalBooleanExprP =

158165

159166restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)

160167restrictionAttributeEqualityP = do

161− attributeName <- identifier

168+ attributeName <- attributeNameP

162169 reservedOp "="

163170 AttributeEqualityPredicate attributeName <$> atomExprP

164171

@@ -175,7 +182,7 @@ extendTupleExpressionP = attributeExtendTupleExpressionP

175182

176183attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)

177184attributeExtendTupleExpressionP = do

178− newAttr <- identifier

185+ newAttr <- attributeNameP

179186 reservedOp ":="

180187 AttributeExtendTupleExpr newAttr <$> atomExprP

181188

@@ -193,14 +200,14 @@ consumeAtomExprP consume = try functionAtomExprP <|>

193200attributeAtomExprP :: Parser (AtomExprBase a)

194201attributeAtomExprP = do

195202 _ <- string "@"

196− AttributeAtomExpr <$> identifier

203+ AttributeAtomExpr <$> attributeNameP

197204

198205nakedAtomExprP :: Parser (AtomExprBase a)

199206nakedAtomExprP = NakedAtomExpr <$> atomP

200207

201208constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)

202209constructedAtomExprP consume = do

203− dConsName <- capitalizedIdentifier

210+ dConsName <- dataConstructorNameP

204211 dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []

205212 ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP

206213

@@ -243,7 +250,7 @@ withMacroExprP = do

243250

244251createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)

245252createViewP = do

246− name <- identifier

253+ name <- relVarNameP

247254 reservedOp "as"

248255 expr <- relExprP

249256 pure (name, expr)

src/bin/TutorialD/Interpreter/Types.hs+10−4

@@ -9,18 +9,24 @@ class RelationalMarkerExpr a where

1010instance RelationalMarkerExpr () where

1111 parseMarkerP = pure ()

12−

12+

13+typeConstructorNameP :: Parser TypeConstructorName

14+typeConstructorNameP = capitalizedIdentifier

15+

16+dataConstructorNameP :: Parser DataConstructorName

17+dataConstructorNameP = capitalizedIdentifier

18+

1319-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.

1420-- data *Either a b* = Left a | Right b

1521typeConstructorDefP :: Parser TypeConstructorDef

16−typeConstructorDefP = ADTypeConstructorDef <$> capitalizedIdentifier <*> typeVarNamesP

22+typeConstructorDefP = ADTypeConstructorDef <$> typeConstructorNameP <*> typeVarNamesP

1723

1824typeVarNamesP :: Parser [TypeVarName]

1925typeVarNamesP = many uncapitalizedIdentifier

2026

2127-- data Either a b = *Left a* | *Right b*

2228dataConstructorDefP :: Parser DataConstructorDef

23−dataConstructorDefP = DataConstructorDef <$> capitalizedIdentifier <*> many dataConstructorDefArgP

29+dataConstructorDefP = DataConstructorDef <$> typeConstructorNameP <*> many dataConstructorDefArgP

2430

2531-- data *Either a b* = Left *a* | Right *b*

2632dataConstructorDefArgP :: Parser DataConstructorDefArg

@@ -47,7 +53,7 @@ typeConstructorP = relationTypeConstructorP <|>

4753 monoTypeConstructorP

4854

4955monoTypeConstructorP :: Parser TypeConstructor

50−monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>

56+monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <|>

5157 TypeVariable <$> uncapitalizedIdentifier

5258

5359