purescript · LiamGoodacre · Oct 21, 2017 · Oct 21, 2017
diff --git a/examples/failing/DuplicateInstance.purs 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
@@ -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
@@ -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
@@ -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
@@ -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