Commit 8eead4de authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve kind-application-error message

parent 4455c86d
......@@ -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)))
{- *********************************************************************
* *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment