diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-08-28 17:23:35 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-08-29 09:37:09 +0100 |
| commit | 8eead4de7c820e602193d6d16acd00faeffa035c (patch) | |
| tree | bf44730f3fa56b160822359170941df62a11eba7 | |
| parent | 4455c86d1635bfb846e750b21dda36dcee028b5e (diff) | |
| download | haskell-8eead4de7c820e602193d6d16acd00faeffa035c.tar.gz | |
Improve kind-application-error message
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 25 |
1 files changed, 15 insertions, 10 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index e85cfe85a1..7878e62c5d 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1391,23 +1391,28 @@ lint_app doc kfn kas -- Note [The substitution invariant] in TyCoRep ; foldlM (go_app in_scope) kfn kas } where - fail_msg = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg kinds =" <+> ppr kas) ] + fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc + , nest 2 (text "Function kind =" <+> ppr kfn) + , nest 2 (text "Arg kinds =" <+> ppr kas) + , extra ] - go_app in_scope kfn ka + go_app in_scope kfn tka | Just kfn' <- coreView kfn - = go_app in_scope kfn' ka + = go_app in_scope kfn' tka - go_app _ (FunTy kfa kfb) (_,ka) - = do { unless (ka `eqType` kfa) (addErrL fail_msg) + go_app _ (FunTy kfa kfb) tka@(_,ka) + = do { unless (ka `eqType` kfa) $ + addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka))) ; return kfb } - go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka) - = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg) + go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) tka@(ta,ka) + = do { let kv_kind = tyVarKind kv + ; unless (ka `eqType` kv_kind) $ + addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka))) ; return (substTyWithInScope in_scope [kv] [ta] kfn) } - go_app _ _ _ = failWithL fail_msg + go_app _ kfn ka + = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka))) {- ********************************************************************* * * |