From 867e4a8aa00bd11f0215c0d40b8a0ed911ab13f5 Mon Sep 17 00:00:00 2001 From: Liam Goodacre Date: Sat, 21 Oct 2017 21:10:12 +0100 Subject: [PATCH] Error on duplicate type class or instance declarations --- examples/failing/DuplicateInstance.purs | 6 ++++++ examples/failing/DuplicateTypeClass.purs | 4 ++++ src/Language/PureScript/AST/Declarations.hs | 2 ++ src/Language/PureScript/Errors.hs | 10 ++++++++++ src/Language/PureScript/TypeChecker.hs | 19 +++++++++++++------ 5 files changed, 35 insertions(+), 6 deletions(-) create mode 100644 examples/failing/DuplicateInstance.purs create mode 100644 examples/failing/DuplicateTypeClass.purs diff --git a/examples/failing/DuplicateInstance.purs b/examples/failing/DuplicateInstance.purs new file mode 100644 index 0000000000..bb3c13e20f --- /dev/null +++ b/examples/failing/DuplicateInstance.purs @@ -0,0 +1,6 @@ +-- @shouldFailWith DuplicateInstance +module Main where +class X +class Y +instance i :: X +instance i :: Y diff --git a/examples/failing/DuplicateTypeClass.purs b/examples/failing/DuplicateTypeClass.purs new file mode 100644 index 0000000000..969c3e3c17 --- /dev/null +++ b/examples/failing/DuplicateTypeClass.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith DuplicateTypeClass +module Main where +class C +class C diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 4e8198d613..0d760ab7df 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -94,6 +94,8 @@ data SimpleErrorMessage | DeclConflict Name Name | ExportConflict (Qualified Name) (Qualified Name) | DuplicateModule ModuleName [SourceSpan] + | DuplicateTypeClass (ProperName 'ClassName) SourceSpan + | DuplicateInstance Ident SourceSpan | DuplicateTypeArgument Text | InvalidDoBind | InvalidDoLet diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 4c7f335708..d260836946 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -103,6 +103,8 @@ errorCode em = case unwrapErrorMessage em of DeclConflict{} -> "DeclConflict" ExportConflict{} -> "ExportConflict" DuplicateModule{} -> "DuplicateModule" + DuplicateTypeClass{} -> "DuplicateTypeClass" + DuplicateInstance{} -> "DuplicateInstance" DuplicateTypeArgument{} -> "DuplicateTypeArgument" InvalidDoBind -> "InvalidDoBind" InvalidDoLet -> "InvalidDoLet" @@ -536,6 +538,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl paras [ line ("Module " <> markCode (runModuleName mn) <> " has been defined multiple times:") , indent . paras $ map (line . displaySourceSpan relPath) ss ] + renderSimpleErrorMessage (DuplicateTypeClass pn ss) = + paras [ line ("Type class " <> markCode (runProperName pn) <> " has been defined multiple times:") + , indent $ line $ displaySourceSpan relPath ss + ] + renderSimpleErrorMessage (DuplicateInstance pn ss) = + paras [ line ("Instance " <> markCode (showIdent pn) <> " has been defined multiple times:") + , indent $ line $ displaySourceSpan relPath ss + ] renderSimpleErrorMessage (CycleInDeclaration nm) = line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed." renderSimpleErrorMessage (CycleInModules mns) = diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index b141651ef3..2d52d9a842 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -116,17 +116,16 @@ addValue moduleName name ty nameKind = do addTypeClass :: forall m . (MonadState CheckState m, MonadError MultipleErrors m) - => ModuleName - -> ProperName 'ClassName + => Qualified (ProperName 'ClassName) -> [(Text, Maybe Kind)] -> [Constraint] -> [FunctionalDependency] -> [Declaration] -> m () -addTypeClass moduleName pn args implies dependencies ds = do +addTypeClass qualifiedClassName args implies dependencies ds = do env <- getEnv traverse_ (checkMemberIsUsable (typeSynonyms env)) classMembers - modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) newClass (typeClasses . checkEnv $ st) } } + modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert qualifiedClassName newClass (typeClasses . checkEnv $ st) } } where classMembers :: [(Ident, Type)] classMembers = map toPair ds @@ -318,11 +317,19 @@ typeCheckAll moduleName _ = traverse go go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration (ss, _) pn args implies deps tys) = do warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (PositionedError ss)) $ do - addTypeClass moduleName pn args implies deps tys + env <- getEnv + let qualifiedClassName = Qualified (Just moduleName) pn + guardWith (errorMessage (DuplicateTypeClass pn ss)) $ + not (M.member qualifiedClassName (typeClasses env)) + addTypeClass qualifiedClassName args implies deps tys return d go (d@(TypeInstanceDeclaration (ss, _) ch idx dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do env <- getEnv + let qualifiedDictName = Qualified (Just moduleName) dictName + flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> + guardWith (errorMessage (DuplicateInstance dictName ss)) $ + not (M.member qualifiedDictName dictionaries) case M.lookup className (typeClasses env) of Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do @@ -331,7 +338,7 @@ typeCheckAll moduleName _ = traverse go checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx (Qualified (Just moduleName) dictName) [] className tys (Just deps') + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) <$> ch) idx qualifiedDictName [] className tys (Just deps') addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict return d