summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Errors.hs6
-rw-r--r--compiler/GHC/Tc/Gen/App.hs91
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs15
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs7
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs21
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs-boot8
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs4
9 files changed, 81 insertions, 75 deletions
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 41bc8cd269..e4296d627d 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -1449,8 +1449,8 @@ mkTyVarEqErr dflags ctxt report ct tv1 ty2
; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 }
mkTyVarEqErr' dflags ctxt report ct tv1 ty2
- | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar; we would have
- -- swapped in Solver.Canonical.canEqTyVarHomo
+ | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have
+ -- swapped in Solver.Canonical.canEqTyVarHomo
|| isTyVarTyVar tv1 && not (isTyVarTy ty2)
|| ctEqRel ct == ReprEq
-- The cases below don't really apply to ReprEq (except occurs check)
@@ -1592,6 +1592,7 @@ mkEqInfoMsg ct ty1 ty2
<+> text "is a non-injective type family"
| otherwise = empty
+{-
isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
-- See Note [Reporting occurs-check errors]
isUserSkolem ctxt tv
@@ -1602,6 +1603,7 @@ isUserSkolem ctxt tv
is_user_skol_info (InferSkol {}) = False
is_user_skol_info _ = True
+-}
misMatchOrCND :: Bool -> ReportErrCtxt -> Ct
-> TcType -> TcType -> Report
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 1f61a508f7..41cd656a5c 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -169,8 +169,10 @@ data HsExprArg (p :: TcPass)
| EWrap !(XEWrap p) -- Wrapper, after instantiation
data EValArg (p :: TcPass) where
- ValArg :: LHsExpr (GhcPass (XPass p)) -> EValArg p
- ValArgQL :: { va_loc :: SrcSpan
+ ValArg :: LHsExpr (GhcPass (XPass p))
+ -> EValArg p
+ ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original expression
+ -- For location and error msgs
, va_fun :: HsExpr GhcTc -- Function, typechecked
, va_args :: [HsExprArg 'TcpInst] -- Args, instantiated
, va_ty :: TcRhoType -- Result type
@@ -181,6 +183,10 @@ mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn
mkEValArg l e = EValArg { eva_loc = l, eva_arg = ValArg e
, eva_ty = noExtField }
+eValArgExpr :: EValArg 'TcpInst -> LHsExpr GhcRn
+eValArgExpr (ValArg e) = e
+eValArgExpr (ValArgQL { va_expr = e }) = e
+
type family XPass p where
XPass 'TcpRn = 'Renamed
XPass 'TcpInst = 'Renamed
@@ -281,7 +287,11 @@ isHsValArg _ = False
countLeadingValArgs :: [HsExprArg id] -> Int
countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args
countLeadingValArgs (EPar {} : args) = countLeadingValArgs args
-countLeadingValArgs _ = 0
+countLeadingValArgs _ = 0
+
+isValArg :: HsExprArg id -> Bool
+isValArg (EValArg {}) = True
+isValArg _ = False
isArgPar :: HsExprArg id -> Bool
isArgPar (EPar {}) = True
@@ -320,11 +330,10 @@ tcInferSigmaTy (L loc rn_expr)
tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp rn_expr exp_res_ty
| (rn_fun, rn_args, rebuild) <- splitHsApps rn_expr
- = do { impred <- impred_call rn_fun
-
- ; (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args
+ = do { (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args
-- Instantiate
+ ; impred <- xoptM LangExt.ImpredicativeTypes
; (delta, inst_args, app_res_rho) <- tcInstFun impred True rn_fun fun_sigma rn_args
-- Quick look at result
@@ -358,14 +367,6 @@ tcApp rn_expr exp_res_ty
-- NB: app_res_ty may be a polytype, via zonkQuickLook
; addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty $
tcWrapResult rn_expr tc_expr app_res_rho exp_res_ty } }
- where
- impred_call :: HsExpr GhcRn -> TcM Bool
- -- Return True if this call can be instantiated impredicatively
- impred_call rn_fun
- | (HsVar _ (L _ f)) <- rn_fun, f `hasKey` dollarIdKey
- = return True -- GHC's special case for ($)
- | otherwise
- = xoptM LangExt.ImpredicativeTypes
----------------
tcInferAppHead :: HsExpr GhcRn
@@ -402,11 +403,10 @@ tcInferAppHead_maybe fun args
HsVar _ (L _ nm) -> Just <$> tcInferId nm
HsRecFld _ f -> Just <$> go_rec_fld f
ExprWithTySig _ e hs_ty
- | isCompleteHsSig hs_ty -> add_ctxt (Just <$> tcExprWithSig e hs_ty)
+ | isCompleteHsSig hs_ty -> addErrCtxt (exprCtxt fun) $
+ Just <$> tcExprWithSig e hs_ty
_ -> return Nothing
where
- add_ctxt thing = addErrCtxt (exprCtxt fun) thing
-
-- Disgusting special case for ambiguous record selectors
go_rec_fld (Ambiguous _ lbl)
| arg1 : _ <- filterOut isArgPar args -- A value arg is first
@@ -444,8 +444,12 @@ tcValArgs quick_look fun args
else return arg_ty
-- Now check the argument
- ; arg' <- addErrCtxt (funAppCtxt fun arg n) $
- tcEValArg arg arg_ty
+ ; arg' <- addErrCtxt (funAppCtxt fun (eValArgExpr arg) n) $
+ do { traceTc "tcEValArg" $
+ vcat [ ppr n <+> text "of" <+> ppr fun
+ , text "arg type:" <+> ppr arg_ty
+ , text "arg:" <+> ppr arg ]
+ ; tcEValArg arg arg_ty }
; return (n+1, eva { eva_arg = ValArg arg', eva_ty = arg_ty }) }
@@ -454,9 +458,10 @@ tcEValArg :: EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)
tcEValArg (ValArg arg) exp_arg_sigma
= tcCheckPolyExprNC arg exp_arg_sigma
-tcEValArg (ValArgQL { va_loc = loc, va_fun = fun, va_args = args
+tcEValArg (ValArgQL { va_expr = L loc _, va_fun = fun, va_args = args
, va_ty = app_res_rho, va_rebuild = rebuild }) exp_arg_sigma
- = do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ])
+ = setSrcSpan loc $
+ do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ])
; tc_args <- tcValArgs True fun args
; co <- unifyType Nothing app_res_rho exp_arg_sigma
; traceTc "tcEValArg }" empty
@@ -469,7 +474,7 @@ tcValArg :: HsExpr GhcRn -- The function (for error messages)
-> TcM (LHsExpr GhcTc) -- Resulting argument
tcValArg fun arg arg_ty arg_no
= addErrCtxt (funAppCtxt fun arg arg_no) $
- do { traceTc "tcArg" $
+ do { traceTc "tcValArg" $
vcat [ ppr arg_no <+> text "of" <+> ppr fun
, text "arg type:" <+> ppr arg_ty
, text "arg:" <+> ppr arg ]
@@ -490,12 +495,14 @@ tcInstFun :: Bool -- True <=> ImpredicativeTypes is on; do quick-look
, [HsExprArg 'TcpInst]
, TcSigmaType )
tcInstFun impred_on inst_final rn_fun fun_sigma rn_args
- = setSrcSpanFromArgs rn_args $
- -- Setting the location is important for the class constraints
- -- that may be emitted from instantiating fun_sigma
- do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args)
+ = do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args)
; go emptyVarSet [] [] fun_sigma rn_args }
where
+ do_ql = impred_on || is_dollar rn_fun
+ -- GHC's special case for ($)
+ is_dollar (HsVar _ (L _ f)) = f `hasKey` dollarIdKey
+ is_dollar _ = False
+
fun_orig = exprCtOrigin rn_fun
herald = sep [ text "The function" <+> quotes (ppr rn_fun)
, text "is applied to"]
@@ -537,7 +544,10 @@ tcInstFun impred_on inst_final rn_fun fun_sigma rn_args
| need_instantiation args
, (tvs, theta, body) <- tcSplitSigmaTy fun_ty
, not (null tvs && null theta)
- = do { (inst_tvs, wrap, fun_rho) <- instantiateSigma fun_orig tvs theta body
+ = do { (inst_tvs, wrap, fun_rho) <- setSrcSpanFromArgs rn_args $
+ instantiateSigma fun_orig tvs theta body
+ -- Setting the location is important for the class constraints
+ -- that may be emitted from instantiating fun_sigma
; go (delta `extendVarSetList` inst_tvs)
(addArgWrap wrap acc) so_far fun_rho args }
@@ -590,9 +600,9 @@ tcInstFun impred_on inst_final rn_fun fun_sigma rn_args
go1 delta acc so_far fun_ty
(eva@(EValArg { eva_arg = ValArg arg }) : rest_args)
- = do { (wrap, arg_ty, res_ty) <- matchActualFunTy herald
- (Just rn_fun) (n_val_args, so_far) fun_ty
- ; (delta', arg') <- if impred_on
+ = do { (wrap, arg_ty, res_ty) <- matchActualFunTy herald (Just (ppr rn_fun))
+ (n_val_args, so_far) fun_ty
+ ; (delta', arg') <- if do_ql
then quickLookArg delta arg arg_ty
else return (delta, ValArg arg)
; let acc' = eva { eva_arg = arg', eva_ty = arg_ty }
@@ -835,8 +845,10 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty
; if not (guarded || no_free_kappas)
then return no_ql_result
else
- do { (delta_app, inst_args, app_res_rho)
- <- tcInstFun True True rn_fun fun_sigma rn_args
+ do { impred_on <- xoptM LangExt.ImpredicativeTypes
+ -- If the parent call is (e1 $ e2) then -XImpredicativeTypes might not be on
+ ; (delta_app, inst_args, app_res_rho)
+ <- tcInstFun impred_on True rn_fun fun_sigma rn_args
; traceTc "quickLookArg" $
vcat [ text "arg:" <+> ppr arg
, text "delta:" <+> ppr delta
@@ -849,7 +861,7 @@ quickLookArg1 guarded delta larg@(L loc arg) arg_ty
; let delta' = delta `unionVarSet` delta_app
; qlUnify delta' arg_ty app_res_rho
- ; let ql_arg = ValArgQL { va_loc = loc, va_fun = fun'
+ ; let ql_arg = ValArgQL { va_expr = larg, va_fun = fun'
, va_args = inst_args
, va_ty = app_res_rho
, va_rebuild = rebuild }
@@ -941,12 +953,9 @@ qlUnify delta ty1 ty2
| kappa `elemVarSet` ty2_tvs
= return () -- Occurs-check
--- | not (isAlmostFunctionFree ty2)
--- = return () -- Sigh. See Note [Quick Look at type families]
-
| otherwise
= do { -- Unify the kinds; see Note [Kinds in QL unify]
- co <- unifyType Nothing ty2_kind kappa_kind
+ ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind
; traceTc "qlUnify:update" $
vcat [ hang (ppr kappa <+> dcolon <+> ppr kappa_kind)
@@ -958,7 +967,6 @@ qlUnify delta ty1 ty2
ty2_kind = typeKind ty2
kappa_kind = tyVarKind kappa
-
{- Note [Quick Look and type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Gah! See impredicative/T18126-nasty.
@@ -1531,7 +1539,8 @@ addFunResCtxt fun args fun_res_ty env_ty
= text "Probable cause:" <+> quotes (ppr fun)
<+> text "is applied to too few arguments"
- | not (null args) -- Is applied to at least one arg
+ -- n_fun < n_env
+ | (n_fun + count isValArg args) >= n_env
, not_fun res_fun
= text "Possible cause:" <+> quotes (ppr fun)
<+> text "is applied to too many arguments"
@@ -1604,7 +1613,9 @@ tcExprPrag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
********************************************************************* -}
addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a
-addExprCtxt e thing_inside = addErrCtxt (exprCtxt (unLoc e)) thing_inside
+addExprCtxt (L _ e) thing_inside
+ | isAtomicHsExpr e = thing_inside
+ | otherwise = addErrCtxt (exprCtxt e) thing_inside
exprCtxt :: HsExpr GhcRn -> SDoc
exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 8f68fdb215..3d0d482c41 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -345,7 +345,7 @@ tcExpr expr@(SectionR x op arg2) res_ty
= do { (op', op_ty) <- tcInferRhoNC op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
<- matchActualFunTysRho (mk_op_msg op) fn_orig
- (Just (unLoc op)) 2 op_ty
+ (Just (ppr op)) 2 op_ty
; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2
; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2'
act_res_ty = mkVisFunTy arg1_ty op_res_ty
@@ -365,7 +365,7 @@ tcExpr expr@(SectionL x arg1 op) res_ty
; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
<- matchActualFunTysRho (mk_op_msg op) fn_orig
- (Just (unLoc op)) n_reqd_args op_ty
+ (Just (ppr op)) n_reqd_args op_ty
; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1
; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op')
act_res_ty = mkVisFunTys arg_tys op_res_ty
@@ -853,7 +853,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
scrut_ty = TcType.substTy scrut_subst con1_res_ty
con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
- ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty
+ ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty
-- NB: normal unification is OK here (as opposed to subsumption),
-- because for this to work out, both record_rho and scrut_ty have
-- to be normal datatypes -- no contravariant stuff can go on
@@ -953,17 +953,14 @@ tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc)
--
-- Some of these started life as a true expression hole "_".
-- Others might simply be variables that accidentally have no binding site
---
--- We turn all of them into HsVar, since HsUnboundVar can't contain an
--- Id; and indeed the evidence for the ExprHole does bind it, so it's
--- not unbound any more!
tcUnboundId rn_expr occ res_ty
= do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531)
; name <- newSysName occ
; let ev = mkLocalId name ty
; emitNewExprHole occ ev ty
- ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr
- (HsVar noExtField (noLoc ev)) ty res_ty }
+ ; let expr' = HsUnboundVar ev occ
+ orig = UnboundOccurrenceOf occ
+ ; tcWrapResultO orig rn_expr expr' ty res_ty }
{- *********************************************************************
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index ed2dbb2729..49754c92fe 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -2408,7 +2408,7 @@ kcCheckDeclHeader_sig kisig name flav
KindedTyVar _ _ v v_hs_ki -> do
v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki
discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]
- unifyKind (Just (HsTyVar noExtField NotPromoted v))
+ unifyKind (Just (ppr v))
(tyBinderType tb)
v_ki
@@ -2954,7 +2954,7 @@ tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)
; mb_tv <- tcLookupLcl_maybe tv_nm
; case mb_tv of
Just (ATyVar _ tv)
- -> do { discardResult $ unifyKind (Just hs_tv)
+ -> do { discardResult $ unifyKind (Just (ppr tv_nm))
kind (tyVarKind tv)
-- This unify rejects:
-- class C (m :: * -> *) where
@@ -2962,9 +2962,6 @@ tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)
; return tv }
_ -> new_tv tv_nm kind }
- where
- hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm)
- -- Used for error messages only
--------------------------------------
-- Binding type/class variables in the
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 21b5165d5b..2cc26c1a4a 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -412,7 +412,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; let expr_orig = lexprCtOrigin expr
herald = text "A view pattern expression expects"
; (expr_wrap1, [inf_arg_ty], inf_res_ty)
- <- matchActualFunTysRho herald expr_orig (Just (unLoc expr)) 1 expr_ty
+ <- matchActualFunTysRho herald expr_orig (Just (ppr expr)) 1 expr_ty
-- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_ty)
-- Check that overall pattern is more polymorphic than arg type
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 4c43d91f3e..a0de90b061 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -874,7 +874,7 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
lhs_kind
; let lhs_applied_ty = lhs_ty `mkTcAppTys` lhs_extra_args
hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats
- ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind
+ ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind
-- Check that the result kind of the TyCon applied to its args
-- is compatible with the explicit signature (or Type, if there
-- is none)
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index 31d7aa10b2..42cdfc0cce 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -84,7 +84,7 @@ import Control.Arrow ( second )
-- returning an uninstantiated sigma-type
matchActualFunTy
:: SDoc -- See Note [Herald for matchExpectedFunTys]
- -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType
+ -> Maybe SDoc -- The thing with type TcSigmaType
-> (Arity, [TcSigmaType]) -- Total number of value args in the call, and
-- types of values args to which function has
-- been applied already (reversed)
@@ -186,7 +186,7 @@ Ugh!
-- for example in function application
matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys]
-> CtOrigin
- -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType
+ -> Maybe SDoc -- the thing with type TcSigmaType
-> Arity
-> TcSigmaType
-> TcM (HsWrapper, [TcSigmaType], TcRhoType)
@@ -521,7 +521,7 @@ tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> Ex
tcWrapResultO orig rn_expr expr actual_ty res_ty
= do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty
, text "Expected:" <+> ppr res_ty ])
- ; wrap <- tcSubTypeNC orig GenSigCtxt (Just rn_expr) actual_ty res_ty
+ ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty
; return (mkHsWrap wrap expr) }
tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTcId
@@ -535,7 +535,7 @@ tcWrapResultMono rn_expr expr act_ty res_ty
= ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )
do { co <- case res_ty of
Infer inf_res -> fillInferResult act_ty inf_res
- Check exp_ty -> unifyType (Just rn_expr) act_ty exp_ty
+ Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty
; return (mkHsWrapCo co expr) }
------------------------
@@ -567,7 +567,7 @@ tcSubType orig ctxt ty_actual ty_expected
tcSubTypeNC :: CtOrigin -- Used when instantiating
-> UserTypeCtxt -- Used when skolemising
- -> Maybe (HsExpr GhcRn) -- The expression that has type 'actual' (if known)
+ -> Maybe SDoc -- The expression that has type 'actual' (if known)
-> TcSigmaType -- Actual type
-> ExpRhoType -- Expected type
-> TcM HsWrapper
@@ -1173,8 +1173,9 @@ The exported functions are all defined as versions of some
non-exported generic functions.
-}
-unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1'
- -> TcTauType -> TcTauType -> TcM TcCoercionN
+unifyType :: Maybe SDoc -- ^ If present, the thing that has type ty1
+ -> TcTauType -> TcTauType -- ty1, ty2
+ -> TcM TcCoercionN -- :: ty1 ~# ty2
-- Actual and expected types
-- Returns a coercion : ty1 ~ ty2
unifyType thing ty1 ty2
@@ -1197,13 +1198,13 @@ unifyTypeET ty1 ty2
, uo_visible = True }
-unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN
-unifyKind thing ty1 ty2
+unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN
+unifyKind mb_thing ty1 ty2
= uType KindLevel origin ty1 ty2
where
origin = TypeEqOrigin { uo_actual = ty1
, uo_expected = ty2
- , uo_thing = ppr <$> thing
+ , uo_thing = mb_thing
, uo_visible = True }
diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot
index 36f3367634..a991607afa 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs-boot
+++ b/compiler/GHC/Tc/Utils/Unify.hs-boot
@@ -4,12 +4,10 @@ import GHC.Prelude
import GHC.Tc.Utils.TcType ( TcTauType )
import GHC.Tc.Types ( TcM )
import GHC.Tc.Types.Evidence ( TcCoercion )
-import GHC.Hs.Expr ( HsExpr )
-import GHC.Hs.Types ( HsType )
-import GHC.Hs.Extension ( GhcRn )
+import GHC.Utils.Outputable( SDoc )
-- This boot file exists only to tie the knot between
-- GHC.Tc.Utils.Unify and Inst
-unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
-unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
+unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion
+unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 4372a39e9d..5ccaa53202 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -915,8 +915,8 @@ zonkExpr env (XExpr (HsWrap co_fn expr))
new_expr <- zonkExpr env1 expr
return (XExpr (HsWrap new_co_fn new_expr))
-zonkExpr _ e@(HsUnboundVar {})
- = return e
+zonkExpr env (HsUnboundVar v occ)
+ = return (HsUnboundVar (zonkIdOcc env v) occ)
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
View Lorry Controller Status