git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #1042, better messages for ExpectedType errors.
bcddafcPhil Freeman
examples/failing/KindStar.pursnew file+8
compare with golang
unifiedsplit
@@ -0,0 +1,8 @@
1+-- @shouldFailWith ExpectedType
2+
3+module X where
4+
5+data List a = Nil | Cons a (List a)
6+
7+test :: List
8+test = Nil
src/Language/PureScript/Errors.hs+5−3
@@ -128,7 +128,7 @@ data SimpleErrorMessage
128 | OverlappingArgNames (Maybe Ident)
128 | OverlappingArgNames (Maybe Ident)
129 | MissingClassMember Ident
129 | MissingClassMember Ident
130 | ExtraneousClassMember Ident
130 | ExtraneousClassMember Ident
131− | ExpectedType Kind
131+ | ExpectedType Type Kind
132 | IncorrectConstructorArity (Qualified ProperName)
132 | IncorrectConstructorArity (Qualified ProperName)
133 | SubsumptionCheckFailed
133 | SubsumptionCheckFailed
134 | ExprDoesNotHaveType Expr Type
134 | ExprDoesNotHaveType Expr Type
@@ -590,8 +590,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
590 line $ "Member " ++ show ident ++ " has not been implemented"
590 line $ "Member " ++ show ident ++ " has not been implemented"
591 goSimple (ExtraneousClassMember ident) =
591 goSimple (ExtraneousClassMember ident) =
592 line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"
592 line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"
593− goSimple (ExpectedType kind) =
593+ goSimple (ExpectedType ty kind) =
594+ paras [ line "In a type-annotated expression x :: t, the type t must have kind *."
594− line $ "Expected type of kind *, was " ++ prettyPrintKind kind
595+ , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead."
596+ ]
595 goSimple (IncorrectConstructorArity nm) =
597 goSimple (IncorrectConstructorArity nm) =
596 line $ "Wrong number of arguments to constructor " ++ show nm
598 line $ "Wrong number of arguments to constructor " ++ show nm
597 goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
599 goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
src/Language/PureScript/TypeChecker.hs+1−1
@@ -206,7 +206,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix
206 warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do
206 warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do
207 env <- getEnv
207 env <- getEnv
208 kind <- kindOf moduleName ty
208 kind <- kindOf moduleName ty
209− guardWith (errorMessage (ExpectedType kind)) $ kind == Star
209+ guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
210 case M.lookup (moduleName, name) (names env) of
210 case M.lookup (moduleName, name) (names env) of
211 Just _ -> throwError . errorMessage $ RedefinedIdent name
211 Just _ -> throwError . errorMessage $ RedefinedIdent name
212 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
212 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, External, Defined) (names env) })
src/Language/PureScript/TypeChecker/Types.hs+7−7
@@ -141,7 +141,7 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
141 ty' <- replaceTypeWildcards ty
141 ty' <- replaceTypeWildcards ty
142 -- Kind check
142 -- Kind check
143 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
143 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
144− checkTypeKind kind
144+ checkTypeKind ty kind
145 -- Check the type with the new names in scope
145 -- Check the type with the new names in scope
146 ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
146 ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
147 val'' <- if checkType
147 val'' <- if checkType
@@ -190,8 +190,8 @@ replaceTypeClassDictionaries mn =
190-- |
190-- |
191-- Check the kind of a type, failing if it is not of kind *.
191-- Check the kind of a type, failing if it is not of kind *.
192--
192--
193−checkTypeKind :: Kind -> UnifyT t Check ()
193+checkTypeKind :: Type -> Kind -> UnifyT t Check ()
194−checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star
194+checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star
195
195
196-- |
196-- |
197-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
197-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
@@ -301,7 +301,7 @@ infer' (SuperClassDictionary className tys) = do
301infer' (TypedValue checkType val ty) = do
301infer' (TypedValue checkType val ty) = do
302 Just moduleName <- checkCurrentModule <$> get
302 Just moduleName <- checkCurrentModule <$> get
303 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
303 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
304− checkTypeKind kind
304+ checkTypeKind ty kind
305 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
305 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
306 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
306 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
307 return $ TypedValue True val' ty'
307 return $ TypedValue True val' ty'
@@ -313,7 +313,7 @@ inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
313inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
313inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
314 Just moduleName <- checkCurrentModule <$> get
314 Just moduleName <- checkCurrentModule <$> get
315 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
315 (kind, args) <- liftCheck $ kindOfWithScopedVars ty
316− checkTypeKind kind
316+ checkTypeKind ty kind
317 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
317 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
318 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
318 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
319 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
319 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
@@ -527,7 +527,7 @@ check' (SuperClassDictionary className tys) _ = do
527check' (TypedValue checkType val ty1) ty2 = do
527check' (TypedValue checkType val ty1) ty2 = do
528 Just moduleName <- checkCurrentModule <$> get
528 Just moduleName <- checkCurrentModule <$> get
529 (kind, args) <- liftCheck $ kindOfWithScopedVars ty1
529 (kind, args) <- liftCheck $ kindOfWithScopedVars ty1
530− checkTypeKind kind
530+ checkTypeKind ty1 kind
531 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
531 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
532 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
532 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
533 val' <- subsumes (Just val) ty1' ty2'
533 val' <- subsumes (Just val) ty1' ty2'
@@ -582,7 +582,7 @@ check' val ty | containsTypeSynonyms ty = do
582 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty
582 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty
583 check val ty'
583 check val ty'
584check' val kt@(KindedType ty kind) = do
584check' val kt@(KindedType ty kind) = do
585− checkTypeKind kind
585+ checkTypeKind ty kind
586 val' <- check' val ty
586 val' <- check' val ty
587 return $ TypedValue True val' kt
587 return $ TypedValue True val' kt
588check' (PositionedValue pos _ val) ty =
588check' (PositionedValue pos _ val) ty =