d971454 · project-m36 · git.iko.soy

git.iko.soy/project-m36

perform additional validation during TypeConstructor definition to validate that existing datatypes mentioned have matching argument counts

commitd97145408be8c7c5286ab79f7ac5b3f350abb994 authorAgentM <agentm@themactionfaction.com> dateSun 19 May 2019, 23:40 (7 years ago) parenta3402fc

3 files changed+47−13

compare with master

unifiedsplit

src/lib/ProjectM36/AtomType.hs+29−4 src/lib/ProjectM36/RelationalExpression.hs+8−8 test/TutorialD/Interpreter.hs+10−1

src/lib/ProjectM36/AtomType.hs+29−4

@@ -139,14 +139,39 @@ resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap

139139

140140-- check that type vars on the right also appear on the left

141141-- check that the data constructor names are unique

142−validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError]

143−validateTypeConstructorDef tConsDef dConsList = execWriter $ do

142+validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> TypeConstructorMapping -> Either RelationalError ()

143+validateTypeConstructorDef tConsDef dConsList tConsMap = do

144144 let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList))

145− mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]

145+ when (length duplicateDConsNames > 0) (Left (someErrors (map DataConstructorNameInUseError duplicateDConsNames)))

146146 let leftSideVars = S.fromList (TCD.typeVars tConsDef)

147147 rightSideVars = S.unions (map DCD.typeVars dConsList)

148148 varsDiff = S.difference leftSideVars rightSideVars

149− mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]

149+ when (S.size varsDiff > 0) (Left (someErrors (map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff))))

150+ mapM_ (\dConsDef -> validateDataConstructorDef dConsDef tConsDef tConsMap) dConsList

151+

152+--check that the data constructor names are not in use (recursively)

153+validateDataConstructorDef :: DataConstructorDef -> TypeConstructorDef -> TypeConstructorMapping -> Either RelationalError ()

154+validateDataConstructorDef (DataConstructorDef dConsName dConsDefArgs) tConsDef tConsMap = do

155+ case findDataConstructor dConsName tConsMap of

156+ Just _ -> Left (DataConstructorNameInUseError dConsName)

157+ Nothing -> do

158+ mapM_ (\arg -> validateDataConstructorDefArg arg tConsDef tConsMap) dConsDefArgs

159+

160+

161+validateDataConstructorDefArg :: DataConstructorDefArg -> TypeConstructorDef -> TypeConstructorMapping -> Either RelationalError ()

162+validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor _ _)) _ _ = Right ()

163+validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg (TypeVariable _)) _ _ = Right ()

164+validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) tConsDef tConsMap = case findTypeConstructor (TC.name tCons) tConsMap of

165+ Nothing -> do

166+ when (TC.name tCons /= TCD.name tConsDef) (Left (NoSuchTypeConstructorName (TC.name tCons))) --allows for recursively-defined types

167+ pure ()

168+ Just (ADTypeConstructorDef _ tConsArgs, _) -> do --validate that the argument count matches- type matching can occur later

169+ let existingCount = length tConsArgs

170+ newCount = length (TC.arguments tCons)

171+ when (newCount /= existingCount) (Left (ConstructedAtomArgumentCountMismatchError existingCount newCount))

172+ pure ()

173+ Just (PrimitiveTypeConstructorDef _ _, _) -> pure ()

174+validateDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) _ _ = Right ()

150175

151176atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType

152177atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False

src/lib/ProjectM36/RelationalExpression.hs+8−8

@@ -430,14 +430,14 @@ evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do

430430 let oldTypes = typeConstructorMapping currentContext

431431 tConsName = TCD.name tConsDef

432432 -- validate that the constructor's types exist

433− case validateTypeConstructorDef tConsDef dConsDefList of

434− errs@(_:_) -> pure (Left (someErrors errs))

435− [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))

436− | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))

437− | otherwise -> do

438− let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]

439− putStateContext $ currentContext { typeConstructorMapping = newTypes }

440− pure (Right ())

433+ case validateTypeConstructorDef tConsDef dConsDefList oldTypes of

434+ Left err -> pure (Left err)

435+ Right _ | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))

436+ | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))

437+ | otherwise -> do

438+ let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]

439+ putStateContext $ currentContext { typeConstructorMapping = newTypes }

440+ pure (Right ())

441441

442442-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.

443443evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do

test/TutorialD/Interpreter.hs+10−1

@@ -73,7 +73,8 @@ main = do

7373 testNonEmptyListType,

7474 testUnresolvedAtomTypes,

7575 testWithClause,

76− testAtomFunctionArgumentMismatch

76+ testAtomFunctionArgumentMismatch,

77+ testInvalidDataConstructor

7778 ]

7879 simpleRelTests = [("x:=true", Right relationTrue),

7980 ("x:=false", Right relationFalse),

@@ -642,3 +643,11 @@ testAtomFunctionArgumentMismatch = TestCase $ do

642643 --wrong argument count

643644 let err2 = "FunctionArgumentCountMismatchError"

644645 expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"

646+

647+testInvalidDataConstructor :: Test

648+testInvalidDataConstructor = TestCase $ do

649+ --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments

650+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

651+ let err1 = "ConstructedAtomArgumentCountMismatchError"

652+ expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int"

653+