import Name
import TyCon
import Type
+import TypeRep
import Coercion
import Var
import VarSet
+import VarEnv
import TysWiredIn
-import TysPrim( intPrimTy )
+import TysPrim( intPrimTy, ecKind )
import PrimOp( tagToEnumKey )
import PrelNames
+import Module
import DynFlags
import SrcLoc
import Util
import ListSetOps
import Maybes
+import ErrUtils
import Outputable
import FastString
import Control.Monad
tcPolyExprNC expr res_ty
= do { traceTc "tcPolyExprNC" (ppr res_ty)
- ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho ->
+ ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
tcMonoExprNC expr rho
; return (mkLHsWrap gen_fn expr') }
%************************************************************************
\begin{code}
+
+updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a
+updHetMetLevel f comp =
+ updEnv
+ (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x)
+ in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } }))
+
+ comp
+
+addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name
+addEscapes [] e = e
+addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e))
+
+getIdLevel :: Name -> TcM [TyVar]
+getIdLevel name
+ = do { thing <- tcLookup name
+ ; case thing of
+ ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel
+ _ -> return []
+ }
+
tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
= pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
tcExpr (HsVar name) res_ty = tcCheckId name res_ty
-tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
+tcExpr (HsHetMetBrak _ e) res_ty =
+ do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty
+ ; fresh_ec_name <- newFlexiTyVar ecKind
+ ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
+ $ tcPolyExpr e elt_ty
+ ; unifyType (TyVarTy fresh_ec_name) inferred_name
+ ; return $ mkHsWrapCo coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }
+tcExpr (HsHetMetEsc _ _ e) res_ty =
+ do { cur_level <- getHetMetLevel
+ ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
+ $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
+ ; ty' <- zonkTcType res_ty
+ ; return $ HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr') }
+tcExpr (HsHetMetCSP _ e) res_ty =
+ do { cur_level <- getHetMetLevel
+ ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
+ $ tcExpr (unLoc e) res_ty
+ ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') }
-tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
- ; tcWrapResult (HsLit lit) lit_ty res_ty }
+tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
+tcExpr (HsLit lit) res_ty =
+ getHetMetLevel >>= \lev ->
+ case lev of
+ [] -> do { let lit_ty = hsLitType lit
+ ; tcWrapResult (HsLit lit) lit_ty res_ty }
+ (ec:rest) -> let n = case lit of
+ (HsChar c) -> hetmet_guest_char_literal_name
+ (HsString str) -> hetmet_guest_string_literal_name
+ (HsInteger i _) -> hetmet_guest_integer_literal_name
+ (HsInt i) -> hetmet_guest_integer_literal_name
+ _ -> error "literals of this sort are not allowed at depth >0"
+ in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $
+ (HsApp (noLoc $ HsVar n) (noLoc $ HsLit lit))) res_ty
+
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar expr') }
= do { expr' <- tcMonoExpr expr res_ty
; return (HsCoreAnn lbl expr') }
-tcExpr (HsOverLit lit) res_ty
- = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
- ; return (HsOverLit lit') }
+tcExpr (HsOverLit lit) res_ty =
+ getHetMetLevel >>= \lev ->
+ case lev of
+ [] -> do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
+ ; return (HsOverLit lit') }
+ (ec:rest) -> let n = case lit of
+ (OverLit { ol_val = HsIntegral i }) -> hetmet_guest_integer_literal_name
+ (OverLit { ol_val = HsIsString fs }) -> hetmet_guest_string_literal_name
+ (OverLit { ol_val = HsFractional f }) -> error "fractional literals not allowed at depth >0"
+ in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $
+ (HsApp (noLoc $ HsVar n) (noLoc $ HsOverLit lit))) res_ty
+
tcExpr (NegApp expr neg_expr) res_ty
= do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr')
- <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty ->
+ <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
-- See Note [More instantiated than scoped] in TcBinds
tcMonoExprNC expr res_ty
; co_res <- unifyType op_res_ty res_ty
; op_id <- tcLookupId op_name
; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
- ; return $ mkHsWrapCoI co_res $
- OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
+ ; return $ mkHsWrapCo co_res $
+ OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
| otherwise
= do { traceTc "Non Application rule" (ppr op)
; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
; co_res <- unifyType op_res_ty res_ty
; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
- ; return $ mkHsWrapCoI co_res $
- OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
+ ; return $ mkHsWrapCo co_res $
+ OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op (arg2, arg2_ty, 2)
- ; return $ mkHsWrapCoI co_res $
- SectionR (mkLHsWrapCoI co_fn op') arg2' }
+ ; return $ mkHsWrapCo co_res $
+ SectionR (mkLHsWrapCo co_fn op') arg2' }
tcExpr (SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
; arg1' <- tcArg op (arg1, arg1_ty, 1)
- ; return $ mkHsWrapCoI co_res $
- SectionL arg1' (mkLHsWrapCoI co_fn op') }
+ ; return $ mkHsWrapCo co_res $
+ SectionL arg1' (mkLHsWrapCo co_fn op') }
tcExpr (ExplicitTuple tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let tup_tc = tupleTyCon boxity (length tup_args)
; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
| otherwise
= -- The tup_args are a mixture of Present and Missing (for tuple sections)
-- Handle tuple sections where
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
tcExpr (ExplicitList _ exprs) res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
+ ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
+ ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
\end{code}
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
-tcExpr (HsIf pred b1 b2) res_ty
- = do { pred' <- tcMonoExpr pred boolTy
- ; b1' <- tcMonoExpr b1 res_ty
- ; b2' <- tcMonoExpr b2 res_ty
- ; return (HsIf pred' b1' b2') }
-
-tcExpr (HsDo do_or_lc stmts body _) res_ty
- = tcDoStmts do_or_lc stmts body res_ty
+tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
+ = do { pred' <- tcMonoExpr pred boolTy
+ ; b1' <- tcMonoExpr b1 res_ty
+ ; b2' <- tcMonoExpr b2 res_ty
+ ; return (HsIf Nothing pred' b1' b2') }
+
+tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if]
+ = do { pred_ty <- newFlexiTyVarTy openTypeKind
+ ; b1_ty <- newFlexiTyVarTy openTypeKind
+ ; b2_ty <- newFlexiTyVarTy openTypeKind
+ ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty
+ ; fun' <- tcSyntaxOp IfOrigin fun if_ty
+ ; pred' <- tcMonoExpr pred pred_ty
+ ; b1' <- tcMonoExpr b1 b1_ty
+ ; b2' <- tcMonoExpr b2 b2_ty
+ -- Fundamentally we are just typing (ifThenElse e1 e2 e3)
+ -- so maybe we should use the code for function applications
+ -- (which would allow ifThenElse to be higher rank).
+ -- But it's a little awkward, so I'm leaving it alone for now
+ -- and it maintains uniformity with other rebindable syntax
+ ; return (HsIf (Just fun') pred' b1' b2') }
+
+tcExpr (HsDo do_or_lc stmts _) res_ty
+ = tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
- ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
+ ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
tcExpr e@(HsArrApp _ _ _ _ _) _
= failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
ptext (sLit "was found where an expression was expected")])
\end{code}
+Note [Rebindable syntax for if]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rebindable syntax for 'if' uses the most flexible possible type
+for conditionals:
+ ifThenElse :: p -> b1 -> b2 -> res
+to support expressions like this:
+
+ ifThenElse :: Maybe a -> (a -> b) -> b -> b
+ ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e
+
+ example :: String
+ example = if Just 2
+ then \v -> show v
+ else "No value"
+
+
%************************************************************************
%* *
Record construction and update
; co_res <- unifyType actual_res_ty res_ty
; rbinds' <- tcRecordBinds data_con arg_tys rbinds
- ; return $ mkHsWrapCoI co_res $
+ ; return $ mkHsWrapCo co_res $
RecordCon (L loc con_id) con_expr rbinds' }
\end{code}
-- Take apart a representative constructor
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
- (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
+ (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
con1_flds = dataConFieldLabels con1
con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
- ; let rec_res_ty = substTy result_inst_env con1_res_ty
- con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
+ ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
- scrut_ty = substTy scrut_subst con1_res_ty
+ scrut_ty = TcType.substTy scrut_subst con1_res_ty
; co_res <- unifyType rec_res_ty res_ty
-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
- = WpCast $ mkTyConApp co_con scrut_inst_tys
+ = WpCast $ mkAxInstCo co_con scrut_inst_tys
| otherwise
= idHsWrapper
-- Phew!
- ; return $ mkHsWrapCoI co_res $
+ ; return $ mkHsWrapCo co_res $
RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys }
where
; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName elt_ty
- ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
+ ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq enum_from_then (FromThen expr1' expr2')) }
tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq enum_from_to (FromTo expr1' expr2')) }
tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
; expr1' <- tcPolyExpr expr1 elt_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
- enumFromToPName elt_ty
- ; return $ mkHsWrapCoI coi
+ (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
+ ; return $ mkHsWrapCo coi
(PArrSeq enum_from_to (FromTo expr1' expr2')) }
tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
- enumFromThenToPName elt_ty
- ; return $ mkHsWrapCoI coi
+ (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
+ ; return $ mkHsWrapCo coi
(PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
-- Typecheck the result, thereby propagating
-- info (if any) from result into the argument types
-- Both actual_res_ty and res_ty are deeply skolemised
- ; co_res <- unifyType actual_res_ty res_ty
+ ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
+ unifyType actual_res_ty res_ty
-- Typecheck the arguments
; args1 <- tcArgs fun args expected_arg_tys
-- Assemble the result
- ; let fun2 = mkLHsWrapCoI co_fun fun1
- app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
+ ; let fun2 = mkLHsWrapCo co_fun fun1
+ app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
; return (unLoc app) }
; (co_fun, expected_arg_tys, actual_res_ty)
<- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
; args1 <- tcArgs fun args expected_arg_tys
- ; let fun2 = mkLHsWrapCoI co_fun fun1
+ ; let fun2 = mkLHsWrapCo co_fun fun1
app = foldl mkHsApp fun2 args1
; return (unLoc app, actual_res_ty) }
----------------
unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
- -> TcM (CoercionI, [TcSigmaType], TcRhoType)
+ -> TcM (Coercion, [TcSigmaType], TcRhoType)
-- A wrapper for matchExpectedFunTys
unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
where
tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
-- Look up an occurrence of an Id, and instantiate it (deeply)
-tcInferIdWithOrig orig id_name
- = do { id <- lookup_id
- ; (id_expr, id_rho) <- instantiateOuter orig id
- ; (wrap, rho) <- deeplyInstantiate orig id_rho
- ; return (mkHsWrap wrap id_expr, rho) }
+tcInferIdWithOrig orig id_name =
+ do { id_level <- getIdLevel id_name
+ ; cur_level <- getHetMetLevel
+ ; if (length id_level < length cur_level)
+ then do { (lhexp, tcrho) <-
+ tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name))
+ ; return (unLoc lhexp, tcrho)
+ }
+ else tcInferIdWithOrig' orig id_name
+ }
+
+tcInferIdWithOrig' orig id_name =
+ do { id <- lookup_id
+ ; (id_expr, id_rho) <- instantiateOuter orig id
+ ; (wrap, rho) <- deeplyInstantiate orig id_rho
+ ; return (mkHsWrap wrap id_expr, rho) }
where
lookup_id :: TcM TcId
lookup_id
= do { thing <- tcLookup id_name
; case thing of
- ATcId { tct_id = id, tct_level = lvl }
+ ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel }
-> do { check_naughty id -- Note [Local record selectors]
; checkThLocalId id lvl
+ ; current_hetMetLevel <- getHetMetLevel
+ ; mapM
+ (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2))
+ (zip variable_hetMetLevel current_hetMetLevel)
; return id }
AGlobal (AnId id)
- -> do { check_naughty id; return id }
- -- A global cannot possibly be ill-staged
+ -> do { check_naughty id
+ ; return id }
+ -- A global cannot possibly be ill-staged in Template Haskell
-- nor does it need the 'lifting' treatment
-- hence no checkTh stuff here
; let theta' = substTheta subst theta
; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
; wrap <- instCall orig tys theta'
- ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
+ ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
where
(tvs, theta, tau) = tcSplitSigmaTy (idType id)
\end{code}
; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
rep_ty = mkTyConApp rep_tc rep_args
- ; return (mkHsWrapCoI coi $ HsApp fun' arg') }
+ ; return (mkHsWrapCo coi $ HsApp fun' arg') }
where
doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
, ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
doc3 = ptext (sLit "No family instance for this type")
get_rep_ty :: TcType -> TyCon -> [TcType]
- -> TcM (CoercionI, TyCon, [TcType])
+ -> TcM (Coercion, TyCon, [TcType])
-- Converts a family type (eg F [a]) to its rep type (eg FList a)
-- and returns a coercion between the two
get_rep_ty ty tc tc_args
| not (isFamilyTyCon tc)
- = return (IdCo ty, tc, tc_args)
+ = return (mkReflCo ty, tc, tc_args)
| otherwise
= do { mb_fam <- tcLookupFamInst tc tc_args
; case mb_fam of
Nothing -> failWithTc (tagToEnumError ty doc3)
Just (rep_tc, rep_args)
- -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
+ -> return ( mkSymCo (mkAxInstCo co_tc rep_args)
, rep_tc, rep_args )
where
co_tc = expectJust "tcTagToEnum" $
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
+funResCtxt :: LHsExpr Name -> TcType -> TcType
+ -> TidyEnv -> TcM (TidyEnv, Message)
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+funResCtxt fun fun_res_ty res_ty env0
+ = do { fun_res' <- zonkTcType fun_res_ty
+ ; res' <- zonkTcType res_ty
+ ; let n_fun = length (fst (tcSplitFunTys fun_res'))
+ n_res = length (fst (tcSplitFunTys res'))
+ what | n_fun > n_res = ptext (sLit "few")
+ | otherwise = ptext (sLit "many")
+ extra | n_fun == n_res = empty
+ | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
+ <+> ptext (sLit "is applied to too") <+> what
+ <+> ptext (sLit "arguments")
+ msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+ ; return (env0, msg $$ extra) }
+
badFieldTypes :: [(Name,TcType)] -> SDoc
badFieldTypes prs
= hang (ptext (sLit "Record update for insufficiently polymorphic field")