Merge pull request purescript#1163 from mjgpy3/1142_extra_type_class_member_error

paf31 · paf31 · commit 2c43ca9deb09 · 2015-06-13T22:31:21.000-07:00
Clarify ExtraneousClassMember vs. MissingClassMember
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -107,6 +107,7 @@ data SimpleErrorMessage
   | ArgListLengthsDiffer Ident
   | OverlappingArgNames (Maybe Ident)
   | MissingClassMember Ident
+  | ExtraneousClassMember Ident
   | ExpectedType Kind
   | IncorrectConstructorArity (Qualified ProperName)
   | SubsumptionCheckFailed
@@ -215,6 +216,7 @@ errorCode em = case unwrapErrorMessage em of
   (ArgListLengthsDiffer _)      -> "ArgListLengthsDiffer"
   (OverlappingArgNames _)       -> "OverlappingArgNames"
   (MissingClassMember _)        -> "MissingClassMember"
+  (ExtraneousClassMember _)     -> "ExtraneousClassMember"
   (ExpectedType _)              -> "ExpectedType"
   (IncorrectConstructorArity _) -> "IncorrectConstructorArity"
   SubsumptionCheckFailed        -> "SubsumptionCheckFailed"
@@ -513,6 +515,8 @@ prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessag
       line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
     goSimple (MissingClassMember ident) =
       line $ "Member " ++ show ident ++ " has not been implemented"
+    goSimple (ExtraneousClassMember ident) =
+      line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"
     goSimple (ExpectedType kind) =
       line $ "Expected type of kind *, was " ++ prettyPrintKind kind
     goSimple (IncorrectConstructorArity nm) =
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -277,7 +277,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
 
   memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
   memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
-    _ <- maybe (throwError . errorMessage $ MissingClassMember ident) return $ lookup ident tys'
+    _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident) return $ lookup ident tys'
     return val
   memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
     val <- memberToValue tys' d
