bcddafc · rowtype-yoga/purescript-native

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

Fix #1042, better messages for ExpectedType errors.

commitbcddafc94852d2bb126b346e4eaff11eb934083d authorPhil Freeman <paf31@cantab.net> dateThu 10 Sep 2015, 21:59 (11 years ago) parent5694421

4 files changed+21−11

compare with golang

unifiedsplit

examples/failing/KindStar.purs+8 src/Language/PureScript/Errors.hs+5−3 src/Language/PureScript/TypeChecker.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+7−7

examples/failing/KindStar.pursnew file+8

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

1+-- @shouldFailWith ExpectedType

3+module X where

5+data List a = Nil | Cons a (List a)

7+test :: List

8+test = Nil

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

@@ -128,7 +128,7 @@ data SimpleErrorMessage

128128 | OverlappingArgNames (Maybe Ident)

129129 | MissingClassMember Ident

130130 | ExtraneousClassMember Ident

131− | ExpectedType Kind

131+ | ExpectedType Type Kind

132132 | IncorrectConstructorArity (Qualified ProperName)

133133 | SubsumptionCheckFailed

134134 | ExprDoesNotHaveType Expr Type

@@ -590,8 +590,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

590590 line $ "Member " ++ show ident ++ " has not been implemented"

591591 goSimple (ExtraneousClassMember ident) =

592592 line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"

593− goSimple (ExpectedType kind) =

594− line $ "Expected type of kind *, was " ++ prettyPrintKind kind

593+ goSimple (ExpectedType ty kind) =

594+ paras [ line "In a type-annotated expression x :: t, the type t must have kind *."

595+ , line $ "The error arises from the type " ++ prettyPrintType ty ++ " having the kind " ++ prettyPrintKind kind ++ " instead."

596+ ]

595597 goSimple (IncorrectConstructorArity nm) =

596598 line $ "Wrong number of arguments to constructor " ++ show nm

597599 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

206206 warnAndRethrow (onErrorMessages (ErrorInForeignImport name)) $ do

207207 env <- getEnv

208208 kind <- kindOf moduleName ty

209− guardWith (errorMessage (ExpectedType kind)) $ kind == Star

209+ guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

210210 case M.lookup (moduleName, name) (names env) of

211211 Just _ -> throwError . errorMessage $ RedefinedIdent name

212212 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

141141 ty' <- replaceTypeWildcards ty

142142 -- Kind check

143143 (kind, args) <- liftCheck $ kindOfWithScopedVars ty

144− checkTypeKind kind

144+ checkTypeKind ty kind

145145 -- Check the type with the new names in scope

146146 ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'

147147 val'' <- if checkType

@@ -190,8 +190,8 @@ replaceTypeClassDictionaries mn =

190190-- |

191191-- Check the kind of a type, failing if it is not of kind *.

192192--

193−checkTypeKind :: Kind -> UnifyT t Check ()

194−checkTypeKind kind = guardWith (errorMessage (ExpectedType kind)) $ kind == Star

193+checkTypeKind :: Type -> Kind -> UnifyT t Check ()

194+checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star

195195

196196-- |

197197-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

@@ -301,7 +301,7 @@ infer' (SuperClassDictionary className tys) = do

301301infer' (TypedValue checkType val ty) = do

302302 Just moduleName <- checkCurrentModule <$> get

303303 (kind, args) <- liftCheck $ kindOfWithScopedVars ty

304− checkTypeKind kind

304+ checkTypeKind ty kind

305305 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

306306 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

307307 return $ TypedValue True val' ty'

@@ -313,7 +313,7 @@ inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)

313313inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do

314314 Just moduleName <- checkCurrentModule <$> get

315315 (kind, args) <- liftCheck $ kindOfWithScopedVars ty

316− checkTypeKind kind

316+ checkTypeKind ty kind

317317 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

318318 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

319319 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

527527check' (TypedValue checkType val ty1) ty2 = do

528528 Just moduleName <- checkCurrentModule <$> get

529529 (kind, args) <- liftCheck $ kindOfWithScopedVars ty1

530− checkTypeKind kind

530+ checkTypeKind ty1 kind

531531 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

532532 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

533533 val' <- subsumes (Just val) ty1' ty2'

@@ -582,7 +582,7 @@ check' val ty | containsTypeSynonyms ty = do

582582 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty

583583 check val ty'

584584check' val kt@(KindedType ty kind) = do

585− checkTypeKind kind

585+ checkTypeKind ty kind

586586 val' <- check' val ty

587587 return $ TypedValue True val' kt

588588check' (PositionedValue pos _ val) ty =