15f251c · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge pull request #2563 from LiamGoodacre/fix/class-instance-arity

15f251cPhil Freeman10 years ago

examples/failing/MPTCs.purs+1−1

compare with golang

unifiedsplit

@@ -1,4 +1,4 @@

1−-- @shouldFailWith KindsDoNotUnify

1+-- @shouldFailWith ClassInstanceArityMismatch

2module Main where

4import Prelude

examples/failing/TooFewClassInstanceArgs.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith ClassInstanceArityMismatch

2+module Main where

4+import Prelude

6+class Foo a b

8+instance fooString :: Foo String

src/Language/PureScript/AST/Declarations.hs+2−1

@@ -134,11 +134,12 @@ data SimpleErrorMessage

134 | CaseBinderLengthDiffers Int [Binder]

135 | IncorrectAnonymousArgument

136 | InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)

137− | DeprecatedRequirePath

138 | CannotGeneralizeRecursiveFunction Ident Type

137 | CannotGeneralizeRecursiveFunction Ident Type

139 | CannotDeriveNewtypeForData (ProperName 'TypeName)

138 | CannotDeriveNewtypeForData (ProperName 'TypeName)

140 | ExpectedWildcard (ProperName 'TypeName)

139 | ExpectedWildcard (ProperName 'TypeName)

141 | CannotUseBindWithDo

140 | CannotUseBindWithDo

141+ -- | instance name, type class, expected argument count, actual argument count

142+ | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int

142 deriving (Show)

143 deriving (Show)

143

144

144-- | Error message hints, providing more detailed information about failure.

145-- | Error message hints, providing more detailed information about failure.

src/Language/PureScript/Errors.hs+9−5

@@ -168,11 +168,11 @@ errorCode em = case unwrapErrorMessage em of

168 CaseBinderLengthDiffers{} -> "CaseBinderLengthDiffers"

169 IncorrectAnonymousArgument -> "IncorrectAnonymousArgument"

170 InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"

171− DeprecatedRequirePath{} -> "DeprecatedRequirePath"

172 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

171 CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"

173 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

172 CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"

174 ExpectedWildcard{} -> "ExpectedWildcard"

173 ExpectedWildcard{} -> "ExpectedWildcard"

175 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

174 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

175+ ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"

176

177-- |

178-- A stack trace for an error

@@ -691,7 +691,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

691 renderSimpleErrorMessage (ExtraneousClassMember ident className) =

692 line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className)

693 renderSimpleErrorMessage (ExpectedType ty kind) =

694− paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode "*" <> "."

694+ paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (prettyPrintKind kindType) <> "."

695 , line "The error arises from the type"

696 , markCodeBox $ indent $ typeAsBox ty

697 , line "having the kind"

@@ -863,9 +863,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

863 , line "Only aliases for data constructors may be used in patterns."

864 ]

865

866− renderSimpleErrorMessage DeprecatedRequirePath =

867− line "The require-path option is deprecated and will be removed in PureScript 0.9."

868−

869 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

866 renderSimpleErrorMessage (CannotGeneralizeRecursiveFunction ident ty) =

870 paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

867 paras [ line $ "Unable to generalize the type of the recursive function " <> markCode (showIdent ident) <> "."

871 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

868 , line $ "The inferred type of " <> markCode (showIdent ident) <> " was:"

@@ -885,6 +882,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

885 paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."

882 paras [ line $ "The name " <> markCode "bind" <> " cannot be brought into scope in a do notation block, since do notation uses the same name."

886 ]

883 ]

887

884

885+ renderSimpleErrorMessage (ClassInstanceArityMismatch dictName className expected actual) =

886+ paras [ line $ "The type class " <> markCode (showQualified runProperName className) <>

887+ " expects " <> T.pack (show expected) <> " argument(s)."

888+ , line $ "But the instance " <> markCode (showIdent dictName) <> " only provided " <>

889+ T.pack (show actual) <> "."

890+ ]

891+

888 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

892 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

889 renderHint (ErrorUnifyingTypes t1 t2) detail =

893 renderHint (ErrorUnifyingTypes t1 t2) detail =

890 paras [ detail

894 paras [ detail

src/Language/PureScript/TypeChecker.hs+8

@@ -297,6 +297,7 @@ typeCheckAll moduleName _ = traverse go

297 case M.lookup className (typeClasses env) of

298 Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration"

299 Just typeClass -> do

300+ checkInstanceArity dictName className typeClass tys

300 sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

301 sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys)

301 checkOrphanInstance dictName className typeClass tys

302 checkOrphanInstance dictName className typeClass tys

302 _ <- traverseTypeInstanceBody checkInstanceMembers body

303 _ <- traverseTypeInstanceBody checkInstanceMembers body

@@ -306,6 +307,13 @@ typeCheckAll moduleName _ = traverse go

306 go (PositionedDeclaration pos com d) =

307 go (PositionedDeclaration pos com d) =

307 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

308 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d

308

309

310+ checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m ()

311+ checkInstanceArity dictName className typeClass tys = do

312+ let typeClassArity = length (typeClassArguments typeClass)

313+ instanceArity = length tys

314+ when (typeClassArity /= instanceArity) $

315+ throwError . errorMessage $ ClassInstanceArityMismatch dictName className typeClassArity instanceArity

316+

309 checkInstanceMembers :: [Declaration] -> m [Declaration]

317 checkInstanceMembers :: [Declaration] -> m [Declaration]

310 checkInstanceMembers instDecls = do

318 checkInstanceMembers instDecls = do

311 let idents = sort . map head . group . map memberName $ instDecls

319 let idents = sort . map head . group . map memberName $ instDecls