Fix 'Unknown type index' on mismatch between class and instance argument counts

LiamGoodacre · LiamGoodacre · commit 28a3095be314 · 2017-01-14T00:34:39.000Z
Error earlier on argument count mismatch
Removed unused error: DeprecatedRequirePath
Fix error message for ExpectedType: print Type instead of *
diff --git a/examples/failing/MPTCs.purs b/examples/failing/MPTCs.purs
@@ -1,4 +1,4 @@
--- @shouldFailWith KindsDoNotUnify
+-- @shouldFailWith ClassInstanceArityMismatch
 module Main where
 
 import Prelude
diff --git a/examples/failing/TooFewClassInstanceArgs.purs b/examples/failing/TooFewClassInstanceArgs.purs
@@ -0,0 +1,8 @@
+-- @shouldFailWith ClassInstanceArityMismatch
+module Main where
+
+import Prelude
+
+class Foo a b
+
+instance fooString :: Foo String
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -134,11 +134,12 @@ data SimpleErrorMessage
   | CaseBinderLengthDiffers Int [Binder]
   | IncorrectAnonymousArgument
   | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
-  | DeprecatedRequirePath
   | CannotGeneralizeRecursiveFunction Ident Type
   | CannotDeriveNewtypeForData (ProperName 'TypeName)
   | ExpectedWildcard (ProperName 'TypeName)
   | CannotUseBindWithDo
+  -- | instance name, type class, expected argument count, actual argument count
+  | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
   deriving (Show)
 
 -- | Error message hints, providing more detailed information about failure.
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -168,11 +168,11 @@ errorCode em = case unwrapErrorMessage em of
   CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"
   IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"
   InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
-  DeprecatedRequirePath{} -> "DeprecatedRequirePath"
   CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
   CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"
   ExpectedWildcard{} -> "ExpectedWildcard"
   CannotUseBindWithDo{} -> "CannotUseBindWithDo"
+  ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"
 
 -- |
 -- A stack trace for an error
@@ -691,7 +691,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
     renderSimpleErrorMessage (ExtraneousClassMember ident className) =
       line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)
     renderSimpleErrorMessage (ExpectedType ty kind) =
-      paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."
+      paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "."
             , line "The error arises from the type"
             , markCodeBox $ indent $ typeAsBox ty
             , line "having the kind"
@@ -863,9 +863,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
             , line "Only aliases for data constructors may be used in patterns."
             ]
 
-    renderSimpleErrorMessage DeprecatedRequirePath =
-      line "The require-path option is deprecated and will be removed in PureScript 0.9."
-
     renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =
       paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."
             , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"
@@ -885,6 +882,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
       paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."
             ]
 
+    renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) =
+      paras [ line $ "The type class " <> markCode (showQualified runProperName className) <>
+                     " expects " <> T.pack (show expected) <> " argument(s)."
+            , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <>
+                     T.pack (show actual) <> "."
+            ]
+
     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
     renderHint (ErrorUnifyingTypes t1 t2) detail =
       paras [ detail
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -297,6 +297,7 @@ typeCheckAll moduleName _ = traverse go
     case M.lookup className (typeClasses env) of
       Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"
       Just typeClass -> do
+        checkInstanceArity dictName className typeClass tys
         sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)
         checkOrphanInstance dictName className typeClass tys
         _ <- traverseTypeInstanceBody checkInstanceMembers body
@@ -306,6 +307,13 @@ typeCheckAll moduleName _ = traverse go
   go (PositionedDeclaration pos com d) =
     warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
 
+  checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()
+  checkInstanceArity dictName className typeClass tys = do
+    let typeClassArity = length (typeClassArguments typeClass)
+        instanceArity = length tys
+    when (typeClassArity /= instanceArity) $
+      throwError . errorMessage $ ClassInstanceArityMismatch dictName className typeClassArity instanceArity
+
   checkInstanceMembers :: [Declaration] -> m [Declaration]
   checkInstanceMembers instDecls = do
     let idents = sort . map head . group . map memberName $ instDecls

Original file line number	Diff line number	Diff line change
`@@ -1,4 +1,4 @@`
`1`		`--- @shouldFailWith KindsDoNotUnify`
	`1`	`+-- @shouldFailWith ClassInstanceArityMismatch`
`2`	`2`	`module Main where`
`3`	`3`
`4`	`4`	`import Prelude`