Commit c2417b87 authored by Richard Eisenberg's avatar Richard Eisenberg

Fix #13819 by refactoring TypeEqOrigin.uo_thing

The uo_thing field of TypeEqOrigin is used to track the
"thing" (either term or type) that has the type (kind) stored
in the TypeEqOrigin fields. Previously, this was sometimes a
proper Core Type, which needed zonking and tidying. Now, it
is only HsSyn: much simpler, and the error messages now use
the user-written syntax.

But this aspect of uo_thing didn't cause #13819; it was the
sibling field uo_arity that did. uo_arity stored the number
of arguments of uo_thing, useful when reporting something
like "should have written 2 fewer arguments". We wouldn't want
to say that if the thing didn't have two arguments. However,
in practice, GHC was getting this wrong, and this message
didn't seem all that helpful. Furthermore, the calculation
of the number of arguments is what caused #13819 to fall over.
This patch just removes uo_arity. In my opinion, the change
to error messages is a nudge in the right direction.

Test case: typecheck/should_fail/T13819
parent 79cfb199
...@@ -637,7 +637,7 @@ addConstraint actual expected = do ...@@ -637,7 +637,7 @@ addConstraint actual expected = do
discardResult $ discardResult $
captureConstraints $ captureConstraints $
do { (ty1, ty2) <- congruenceNewtypes actual expected do { (ty1, ty2) <- congruenceNewtypes actual expected
; unifyType noThing ty1 ty2 } ; unifyType Nothing ty1 ty2 }
-- TOMDO: what about the coercion? -- TOMDO: what about the coercion?
-- we should consider family instances -- we should consider family instances
...@@ -1186,7 +1186,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') ...@@ -1186,7 +1186,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
(_, vars) <- instTyVars (tyConTyVars new_tycon) (_, vars) <- instTyVars (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon (mkTyVarTys vars) let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
rep_ty = unwrapType ty' rep_ty = unwrapType ty'
_ <- liftTcM (unifyType noThing ty rep_ty) _ <- liftTcM (unifyType Nothing ty rep_ty)
-- assumes that reptype doesn't ^^^^ touch tyconApp args -- assumes that reptype doesn't ^^^^ touch tyconApp args
return ty' return ty'
......
...@@ -33,7 +33,7 @@ module Inst ( ...@@ -33,7 +33,7 @@ module Inst (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp )
import {-# SOURCE #-} TcUnify( unifyType, unifyKind, noThing ) import {-# SOURCE #-} TcUnify( unifyType, unifyKind )
import BasicTypes ( IntegralLit(..), SourceText(..) ) import BasicTypes ( IntegralLit(..), SourceText(..) )
import FastString import FastString
...@@ -324,13 +324,13 @@ instCallConstraints orig preds ...@@ -324,13 +324,13 @@ instCallConstraints orig preds
where where
go pred go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1 | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
= do { co <- unifyType noThing ty1 ty2 = do { co <- unifyType Nothing ty1 ty2
; return (EvCoercion co) } ; return (EvCoercion co) }
-- Try short-cut #2 -- Try short-cut #2
| Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
, tc `hasKey` heqTyConKey , tc `hasKey` heqTyConKey
= do { co <- unifyType noThing ty1 ty2 = do { co <- unifyType Nothing ty1 ty2
; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) } ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }
| otherwise | otherwise
...@@ -409,7 +409,7 @@ tcInstBinder _ subst (Anon ty) ...@@ -409,7 +409,7 @@ tcInstBinder _ subst (Anon ty)
, uo_expected = k2 , uo_expected = k2
, uo_thing = Nothing } , uo_thing = Nothing }
; co <- case role of ; co <- case role of
Nominal -> unifyKind noThing k1 k2 Nominal -> unifyKind Nothing k1 k2
Representational -> emitWantedEq origin KindLevel role k1 k2 Representational -> emitWantedEq origin KindLevel role k1 k2
Phantom -> pprPanic "tcInstBinder Phantom" (ppr ty) Phantom -> pprPanic "tcInstBinder Phantom" (ppr ty)
; arg' <- mk co k1 k2 ; arg' <- mk co k1 k2
......
...@@ -275,7 +275,7 @@ tc_cmd env ...@@ -275,7 +275,7 @@ tc_cmd env
-- Do notation -- Do notation
tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty)
= do { co <- unifyType noThing unitTy cmd_stk -- Expecting empty argument stack = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack
; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) } ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) }
......
...@@ -1684,7 +1684,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 ...@@ -1684,7 +1684,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
= do { let main_msg = addArising (ctOrigin ct) $ = do { let main_msg = addArising (ctOrigin ct) $
vcat [ hang (text "Kind mismatch: cannot unify" <+> vcat [ hang (text "Kind mismatch: cannot unify" <+>
parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+> parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>
text "with") text "with:")
2 (sep [ppr ty2, dcolon, ppr k2]) 2 (sep [ppr ty2, dcolon, ppr k2])
, text "Their kinds differ." ] , text "Their kinds differ." ]
cast_msg cast_msg
...@@ -1999,7 +1999,7 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act ...@@ -1999,7 +1999,7 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
-> empty -> empty
thing_msg = case maybe_thing of thing_msg = case maybe_thing of
Just thing -> \_ -> quotes (ppr thing) <+> text "is" Just thing -> \_ -> quotes thing <+> text "is"
Nothing -> \vowel -> text "got a" <> Nothing -> \vowel -> text "got a" <>
if vowel then char 'n' else empty if vowel then char 'n' else empty
msg2 = sep [ text "Expecting a lifted type, but" msg2 = sep [ text "Expecting a lifted type, but"
...@@ -2009,12 +2009,12 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act ...@@ -2009,12 +2009,12 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
msg4 = maybe_num_args_msg $$ msg4 = maybe_num_args_msg $$
sep [ text "Expected a type, but" sep [ text "Expected a type, but"
, maybe (text "found something with kind") , maybe (text "found something with kind")
(\thing -> quotes (ppr thing) <+> text "has kind") (\thing -> quotes thing <+> text "has kind")
maybe_thing maybe_thing
, quotes (ppr act) ] , quotes (ppr act) ]
msg5 th = hang (text "Expected" <+> kind_desc <> comma) msg5 th = hang (text "Expected" <+> kind_desc <> comma)
2 (text "but" <+> quotes (ppr th) <+> text "has kind" <+> 2 (text "but" <+> quotes th <+> text "has kind" <+>
quotes (ppr act)) quotes (ppr act))
where where
kind_desc | isConstraintKind exp = text "a constraint" kind_desc | isConstraintKind exp = text "a constraint"
...@@ -2026,17 +2026,13 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act ...@@ -2026,17 +2026,13 @@ mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
-> let n_act = count_args act -> let n_act = count_args act
n_exp = count_args exp in n_exp = count_args exp in
case n_act - n_exp of case n_act - n_exp of
n | n /= 0 n | n > 0 -- we don't know how many args there are, so don't
-- recommend removing args that aren't
, Just thing <- maybe_thing , Just thing <- maybe_thing
, case errorThingNumArgs_maybe thing of
Nothing -> n > 0
Just num_act_args -> num_act_args >= -n
-- don't report to strip off args that aren't there
-> Just $ text "Expecting" <+> speakN (abs n) <+> -> Just $ text "Expecting" <+> speakN (abs n) <+>
more_or_fewer <+> quotes (ppr thing) more <+> quotes thing
where where
more_or_fewer more
| n < 0 = text "fewer arguments to"
| n == 1 = text "more argument to" | n == 1 = text "more argument to"
| otherwise = text "more arguments to" -- n > 1 | otherwise = text "more arguments to" -- n > 1
_ -> Nothing _ -> Nothing
......
...@@ -166,8 +166,8 @@ NB: The res_ty is always deeply skolemised. ...@@ -166,8 +166,8 @@ NB: The res_ty is always deeply skolemised.
-} -}
tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty tcExpr e@(HsUnboundVar uv) res_ty = tcUnboundId e uv res_ty
tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
...@@ -370,7 +370,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ...@@ -370,7 +370,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
; let doc = text "The first argument of ($) takes" ; let doc = text "The first argument of ($) takes"
orig1 = lexprCtOrigin arg1 orig1 = lexprCtOrigin arg1
; (wrap_arg1, [arg2_sigma], op_res_ty) <- ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty
-- We have (arg1 $ arg2) -- We have (arg1 $ arg2)
-- So: arg1_ty = arg2_ty -> op_res_ty -- So: arg1_ty = arg2_ty -> op_res_ty
...@@ -385,7 +385,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ...@@ -385,7 +385,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
-- --
-- The *result* type can have any kind (Trac #8739), -- The *result* type can have any kind (Trac #8739),
-- so we don't need to check anything for that -- so we don't need to check anything for that
; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind ; _ <- unifyKind (Just (HsCoreTy arg2_sigma)) (typeKind arg2_sigma) liftedTypeKind
-- ignore the evidence. arg2_sigma must have type * or #, -- ignore the evidence. arg2_sigma must have type * or #,
-- because we know arg2_sigma -> or_res_ty is well-kinded -- because we know arg2_sigma -> or_res_ty is well-kinded
-- (because otherwise matchActualFunTys would fail) -- (because otherwise matchActualFunTys would fail)
...@@ -434,7 +434,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ...@@ -434,7 +434,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
tcExpr expr@(SectionR op arg2) res_ty tcExpr expr@(SectionR op arg2) res_ty
= do { (op', op_ty) <- tcInferFun op = do { (op', op_ty) <- tcInferFun op
; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
<- matchActualFunTys (mk_op_msg op) fn_orig (Just op) 2 op_ty <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
(mkFunTy arg1_ty op_res_ty) res_ty (mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op arg2 arg2_ty 2 ; arg2' <- tcArg op arg2 arg2_ty 2
...@@ -453,7 +453,7 @@ tcExpr expr@(SectionL arg1 op) res_ty ...@@ -453,7 +453,7 @@ tcExpr expr@(SectionL arg1 op) res_ty
| otherwise = 2 | otherwise = 2
; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
<- matchActualFunTys (mk_op_msg op) fn_orig (Just op) <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))
n_reqd_args op_ty n_reqd_args op_ty
; wrap_res <- tcSubTypeHR SectionOrigin (Just expr) ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
(mkFunTys arg_tys op_res_ty) res_ty (mkFunTys arg_tys op_res_ty) res_ty
...@@ -938,7 +938,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty ...@@ -938,7 +938,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
; wrap_res <- tcSubTypeHR (exprCtOrigin expr) ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
(Just expr) rec_res_ty res_ty (Just expr) rec_res_ty res_ty
; co_scrut <- unifyType (Just record_expr) record_rho scrut_ty ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty
-- NB: normal unification is OK here (as opposed to subsumption), -- NB: normal unification is OK here (as opposed to subsumption),
-- because for this to work out, both record_rho and scrut_ty have -- because for this to work out, both record_rho and scrut_ty have
-- to be normal datatypes -- no contravariant stuff can go on -- to be normal datatypes -- no contravariant stuff can go on
...@@ -974,8 +974,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty ...@@ -974,8 +974,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
, rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys
, rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } } , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } }
tcExpr (HsRecFld f) res_ty tcExpr e@(HsRecFld f) res_ty
= tcCheckRecSelId f res_ty = tcCheckRecSelId e f res_ty
{- {-
************************************************************************ ************************************************************************
...@@ -1037,10 +1037,10 @@ tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr))) ...@@ -1037,10 +1037,10 @@ tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr)))
tcExpr expr res_ty tcExpr expr res_ty
tcExpr (HsSpliceE splice) res_ty tcExpr (HsSpliceE splice) res_ty
= tcSpliceExpr splice res_ty = tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty tcExpr e@(HsBracket brack) res_ty
= tcTypedBracket brack res_ty = tcTypedBracket e brack res_ty
tcExpr (HsRnBracketOut brack ps) res_ty tcExpr e@(HsRnBracketOut brack ps) res_ty
= tcUntypedBracket brack ps res_ty = tcUntypedBracket e brack ps res_ty
{- {-
************************************************************************ ************************************************************************
...@@ -1194,7 +1194,7 @@ tcApp m_herald orig_fun orig_args res_ty ...@@ -1194,7 +1194,7 @@ tcApp m_herald orig_fun orig_args res_ty
-- up to call that function -- up to call that function
; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $ ; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
tcSubTypeDS_NC_O orig GenSigCtxt tcSubTypeDS_NC_O orig GenSigCtxt
(Just $ foldl mk_hs_app fun args) (Just $ unLoc $ foldl mk_hs_app fun args)
actual_res_ty res_ty actual_res_ty res_ty
; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) } ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
...@@ -1290,7 +1290,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald ...@@ -1290,7 +1290,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
go acc_args n fun_ty (Left arg : args) go acc_args n fun_ty (Left arg : args)
= do { (wrap, [arg_ty], res_ty) = do { (wrap, [arg_ty], res_ty)
<- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty
acc_args orig_arity acc_args orig_arity
-- wrap :: fun_ty "->" arg_ty -> res_ty -- wrap :: fun_ty "->" arg_ty -> res_ty
; arg' <- tcArg fun arg arg_ty n ; arg' <- tcArg fun arg arg_ty n
...@@ -1449,7 +1449,7 @@ tcSynArgA :: CtOrigin ...@@ -1449,7 +1449,7 @@ tcSynArgA :: CtOrigin
-- and a wrapper to be applied to the overall expression -- and a wrapper to be applied to the overall expression
tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty) = do { (match_wrapper, arg_tys, res_ty)
<- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty
-- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
; ((result, res_wrapper), arg_wrappers) ; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e arg_tys arg_shapes $ \ arg_results -> <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
...@@ -1623,18 +1623,18 @@ tcCheckId name res_ty ...@@ -1623,18 +1623,18 @@ tcCheckId name res_ty
= do { (expr, actual_res_ty) <- tcInferId name = do { (expr, actual_res_ty) <- tcInferId name
; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty } tcWrapResultO (OccurrenceOf name) (HsVar (noLoc name)) expr actual_res_ty res_ty }
tcCheckRecSelId :: AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty tcCheckRecSelId rn_expr f@(Unambiguous (L _ lbl) _) res_ty
= do { (expr, actual_res_ty) <- tcInferRecSelId f = do { (expr, actual_res_ty) <- tcInferRecSelId f
; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty } tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty }
tcCheckRecSelId (Ambiguous lbl _) res_ty tcCheckRecSelId rn_expr (Ambiguous lbl _) res_ty
= case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
Nothing -> ambiguousSelector lbl Nothing -> ambiguousSelector lbl
Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty } ; tcCheckRecSelId rn_expr (Unambiguous lbl sel_name) res_ty }
------------------------ ------------------------
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
...@@ -1724,7 +1724,7 @@ tc_infer_id lbl id_name ...@@ -1724,7 +1724,7 @@ tc_infer_id lbl id_name
| otherwise = return () | otherwise = return ()
tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
-- Typecheck an occurrence of an unbound Id -- Typecheck an occurrence of an unbound Id
-- --
-- Some of these started life as a true expression hole "_". -- Some of these started life as a true expression hole "_".
...@@ -1733,7 +1733,7 @@ tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId) ...@@ -1733,7 +1733,7 @@ tcUnboundId :: UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
-- We turn all of them into HsVar, since HsUnboundVar can't contain an -- We turn all of them into HsVar, since HsUnboundVar can't contain an
-- Id; and indeed the evidence for the CHoleCan does bind it, so it's -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
-- not unbound any more! -- not unbound any more!
tcUnboundId unbound res_ty tcUnboundId rn_expr unbound res_ty
= do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (Trac #12531) = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (Trac #12531)
; let occ = unboundVarOcc unbound ; let occ = unboundVarOcc unbound
; name <- newSysName occ ; name <- newSysName occ
...@@ -1745,7 +1745,7 @@ tcUnboundId unbound res_ty ...@@ -1745,7 +1745,7 @@ tcUnboundId unbound res_ty
, ctev_loc = loc} , ctev_loc = loc}
, cc_hole = ExprHole unbound } , cc_hole = ExprHole unbound }
; emitInsoluble can ; emitInsoluble can
; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty } ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar (noLoc ev)) ty res_ty }
{- {-
......
...@@ -270,11 +270,12 @@ tcHsClsInstType user_ctxt hs_inst_ty ...@@ -270,11 +270,12 @@ tcHsClsInstType user_ctxt hs_inst_ty
-- Used for 'VECTORISE [SCALAR] instance' declarations -- Used for 'VECTORISE [SCALAR] instance' declarations
tcHsVectInst :: LHsSigType GhcRn -> TcM (Class, [Type]) tcHsVectInst :: LHsSigType GhcRn -> TcM (Class, [Type])
tcHsVectInst ty tcHsVectInst ty
| Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe (hsSigType ty) | let hs_cls_ty = hsSigType ty
, Just (L _ cls_name, tys) <- hsTyGetAppHead_maybe hs_cls_ty
-- Ignoring the binders looks pretty dodgy to me -- Ignoring the binders looks pretty dodgy to me
= do { (cls, cls_kind) <- tcClass cls_name = do { (cls, cls_kind) <- tcClass cls_name
; (applied_class, _res_kind) ; (applied_class, _res_kind)
<- tcInferApps typeLevelMode cls_name (mkClassPred cls []) cls_kind tys <- tcInferApps typeLevelMode hs_cls_ty (mkClassPred cls []) cls_kind tys
; case tcSplitTyConApp_maybe applied_class of ; case tcSplitTyConApp_maybe applied_class of
Just (_tc, args) -> ASSERT( _tc == classTyCon cls ) Just (_tc, args) -> ASSERT( _tc == classTyCon cls )
return (cls, args) return (cls, args)
...@@ -470,11 +471,11 @@ tc_infer_hs_type mode (HsAppTy ty1 ty2) ...@@ -470,11 +471,11 @@ tc_infer_hs_type mode (HsAppTy ty1 ty2)
; fun_kind' <- zonkTcType fun_kind ; fun_kind' <- zonkTcType fun_kind
; tcInferApps mode fun_ty fun_ty' fun_kind' arg_tys } ; tcInferApps mode fun_ty fun_ty' fun_kind' arg_tys }
tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t
tc_infer_hs_type mode (HsOpTy lhs (L _ op) rhs) tc_infer_hs_type mode (HsOpTy lhs (L loc_op op) rhs)
| not (op `hasKey` funTyConKey) | not (op `hasKey` funTyConKey)
= do { (op', op_kind) <- tcTyVar mode op = do { (op', op_kind) <- tcTyVar mode op
; op_kind' <- zonkTcType op_kind ; op_kind' <- zonkTcType op_kind
; tcInferApps mode op op' op_kind' [lhs, rhs] } ; tcInferApps mode (noLoc $ HsTyVar NotPromoted (L loc_op op)) op' op_kind' [lhs, rhs] }
tc_infer_hs_type mode (HsKindSig ty sig) tc_infer_hs_type mode (HsKindSig ty sig)
= do { sig' <- tc_lhs_kind (kindLevel mode) sig = do { sig' <- tc_lhs_kind (kindLevel mode) sig
; ty' <- tc_lhs_type mode ty sig' ; ty' <- tc_lhs_type mode ty sig'
...@@ -510,11 +511,11 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of ...@@ -510,11 +511,11 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
; res_k <- newOpenTypeKind ; res_k <- newOpenTypeKind
; ty1' <- tc_lhs_type mode ty1 arg_k ; ty1' <- tc_lhs_type mode ty1 arg_k
; ty2' <- tc_lhs_type mode ty2 res_k ; ty2' <- tc_lhs_type mode ty2 res_k
; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind } ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
KindLevel -> -- no representation polymorphism in kinds. yet. KindLevel -> -- no representation polymorphism in kinds. yet.
do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
; ty2' <- tc_lhs_type mode ty2 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
; checkExpectedKind (mkFunTy ty1' ty2') liftedTypeKind exp_kind } ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind }
------------------------------------------ ------------------------------------------
-- See also Note [Bidirectional type checking] -- See also Note [Bidirectional type checking]
...@@ -579,30 +580,30 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind ...@@ -579,30 +580,30 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
else do { ek <- newOpenTypeKind else do { ek <- newOpenTypeKind
-- The body kind (result of the function) -- The body kind (result of the function)
-- can be * or #, hence newOpenTypeKind -- can be * or #, hence newOpenTypeKind
; ty <- tc_lhs_type mode ty ek ; ty' <- tc_lhs_type mode ty ek
; checkExpectedKind ty liftedTypeKind exp_kind } ; checkExpectedKind (unLoc ty) ty' liftedTypeKind exp_kind }
; return (mkPhiTy ctxt' ty') } ; return (mkPhiTy ctxt' ty') }
--------- Lists, arrays, and tuples --------- Lists, arrays, and tuples
tc_hs_type mode (HsListTy elt_ty) exp_kind tc_hs_type mode rn_ty@(HsListTy elt_ty) exp_kind
= do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
; checkWiredInTyCon listTyCon ; checkWiredInTyCon listTyCon
; checkExpectedKind (mkListTy tau_ty) liftedTypeKind exp_kind } ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
tc_hs_type mode (HsPArrTy elt_ty) exp_kind tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind
= do { MASSERT( isTypeLevel (mode_level mode) ) = do { MASSERT( isTypeLevel (mode_level mode) )
; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
; checkWiredInTyCon parrTyCon ; checkWiredInTyCon parrTyCon
; checkExpectedKind (mkPArrTy tau_ty) liftedTypeKind exp_kind } ; checkExpectedKind rn_ty (mkPArrTy tau_ty) liftedTypeKind exp_kind }
-- See Note [Distinguishing tuple kinds] in HsTypes -- See Note [Distinguishing tuple kinds] in HsTypes
-- See Note [Inferring tuple kinds] -- See Note [Inferring tuple kinds]
tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
-- (NB: not zonking before looking at exp_k, to avoid left-right bias) -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
| Just tup_sort <- tupKindSort_maybe exp_kind | Just tup_sort <- tupKindSort_maybe exp_kind
= traceTc "tc_hs_type tuple" (ppr hs_tys) >> = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
tc_tuple mode tup_sort hs_tys exp_kind tc_tuple rn_ty mode tup_sort hs_tys exp_kind
| otherwise | otherwise
= do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys
...@@ -620,14 +621,14 @@ tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind ...@@ -620,14 +621,14 @@ tc_hs_type mode (HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind
-- In the [] case, it's not clear what the kind is, so guess * -- In the [] case, it's not clear what the kind is, so guess *
; tys' <- sequence [ setSrcSpan loc $ ; tys' <- sequence [ setSrcSpan loc $
checkExpectedKind ty kind arg_kind checkExpectedKind hs_ty ty kind arg_kind
| ((L loc _),ty,kind) <- zip3 hs_tys tys kinds ] | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
; finish_tuple tup_sort tys' (map (const arg_kind) tys') exp_kind } ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind
= tc_tuple mode tup_sort tys exp_kind = tc_tuple rn_ty mode tup_sort tys exp_kind
where where
tup_sort = case hs_tup_sort of -- Fourth case dealt with above tup_sort = case hs_tup_sort of -- Fourth case dealt with above
HsUnboxedTuple -> UnboxedTuple HsUnboxedTuple -> UnboxedTuple
...@@ -635,28 +636,29 @@ tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind ...@@ -635,28 +636,29 @@ tc_hs_type mode (HsTupleTy hs_tup_sort tys) exp_kind
HsConstraintTuple -> ConstraintTuple HsConstraintTuple -> ConstraintTuple
_ -> panic "tc_hs_type HsTupleTy" _ -> panic "tc_hs_type HsTupleTy"
tc_hs_type mode (HsSumTy hs_tys) exp_kind tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind
= do { let arity = length hs_tys = do { let arity = length hs_tys
; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds ; let arg_reps = map (getRuntimeRepFromKind "tc_hs_type HsSumTy") arg_kinds
arg_tys = arg_reps ++ tau_tys arg_tys = arg_reps ++ tau_tys
; checkExpectedKind (mkTyConApp (sumTyCon arity) arg_tys) ; checkExpectedKind rn_ty
(mkTyConApp (sumTyCon arity) arg_tys)
(unboxedSumKind arg_reps) (unboxedSumKind arg_reps)
exp_kind exp_kind
} }
--------- Promoted lists and tuples --------- Promoted lists and tuples
tc_hs_type mode (HsExplicitListTy _ _k tys) exp_kind tc_hs_type m