Commit 15b9bf4b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve typechecking of let-bindings

This major commit was initially triggered by #11339, but it spiraled
into a major review of the way in which type signatures for bindings
are handled, especially partial type signatures.  On the way I fixed a
number of other bugs, namely
   #12069
   #12033
   #11700
   #11339
   #11670

The main change is that I completely reorganised the way in which type
signatures in bindings are handled. The new story is in TcSigs
Note [Overview of type signatures].  Some specific:

* Changes in the data types for signatures in TcRnTypes:
  TcIdSigInfo and new TcIdSigInst

* New module TcSigs deals with typechecking type signatures
  and pragmas. It contains code mostly moved from TcBinds,
  which is already too big

* HsTypes: I swapped the nesting of HsWildCardBndrs
  and HsImplicitBndsrs, so that the wildcards are on the
  oustide not the insidde in a LHsSigWcType.  This is just
  a matter of convenient, nothing deep.

There are a host of other changes as knock-on effects, and
it all took FAR longer than I anticipated :-).  But it is
a significant improvement, I think.

Lots of error messages changed slightly, some just variants but
some modest improvements.

New tests

* typecheck/should_compile
    * SigTyVars: a scoped-tyvar test
    * ExPat, ExPatFail: existential pattern bindings
    * T12069
    * T11700
    * T11339

* partial-sigs/should_compile
    * T12033
    * T11339a
    * T11670

One thing to check:

* Small change to output from ghc-api/landmines.
  Need to check with Alan Zimmerman
parent d25cb61a
......@@ -189,8 +189,8 @@ hsSigTvBinders binds
-- here 'k' scopes too
get_scoped_tvs (L _ (TypeSig _ sig))
| HsIB { hsib_vars = implicit_vars
, hsib_body = sig1 } <- sig
, (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1)
, hsib_body = hs_ty } <- hswc_body sig
, (explicit_vars, _) <- splitLHsForAllTy hs_ty
= implicit_vars ++ map hsLTyVarName explicit_vars
get_scoped_tvs _ = []
......@@ -567,7 +567,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n sig))
| HsIB { hsib_vars = vars } <- sig
| HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
= unLoc n : vars
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
......@@ -735,8 +735,8 @@ rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
-- We must special-case the top-level explicit for-all of a TypeSig
-- See Note [Scoped type variables in bindings]
rep_wc_ty_sig mk_sig loc sig_ty nm
| HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
| HsIB { hsib_vars = implicit_tvs, hsib_body = hs_ty } <- hswc_body sig_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
= do { nm1 <- lookupLOcc nm
; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
......@@ -917,8 +917,8 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
(univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 })
= repHsSigType (ib_ty { hsib_body = hswc_body sig1 })
repHsSigWcType (HsWC { hswc_body = sig1 })
= repHsSigType sig1
-- yield the representation of a list of types
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
......
......@@ -15,7 +15,6 @@ module DsMonad (
foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
Applicative(..),(<$>),
newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs,
......
......@@ -399,6 +399,7 @@ Library
TcAnnotations
TcArrows
TcBinds
TcSigs
TcClassDcl
TcDefaults
TcDeriv
......
......@@ -288,16 +288,12 @@ data HsWildCardBndrs name thing
-- See Note [The wildcard story for types]
= HsWC { hswc_wcs :: PostRn name [Name]
-- Wild cards, both named and anonymous
-- after the renamer
, hswc_ctx :: Maybe SrcSpan
-- Indicates whether hswc_body has an
-- extra-constraint wildcard, and if so where
-- e.g. (Eq a, _) => a -> a
-- NB: the wildcard stays in HsQualTy inside the type!
-- So for pretty printing purposes you can ignore
-- hswc_ctx
, hswc_body :: thing -- Main payload (type or list of types)
, hswc_body :: thing
-- Main payload (type or list of types)
-- If there is an extra-constraints wildcard,
-- it's still there in the hsc_body.
}
deriving instance (Data name, Data thing, Data (PostRn name [Name]))
......@@ -308,7 +304,7 @@ deriving instance (Data name, Data thing, Data (PostRn name [Name]))
type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only
type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only
type LHsSigWcType name = HsImplicitBndrs name (LHsWcType name) -- Both
type LHsSigWcType name = HsWildCardBndrs name (LHsSigType name) -- Both
-- See Note [Representing type signatures]
......@@ -319,11 +315,11 @@ hsSigType :: LHsSigType name -> LHsType name
hsSigType = hsImplicitBody
hsSigWcType :: LHsSigWcType name -> LHsType name
hsSigWcType sig_ty = hswc_body (hsib_body sig_ty)
hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
dropWildCards :: LHsSigWcType name -> LHsSigType name
-- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = sig_ty { hsib_body = hsSigWcType sig_ty }
dropWildCards sig_ty = hswc_body sig_ty
{- Note [Representing type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -351,8 +347,7 @@ mkHsImplicitBndrs x = HsIB { hsib_body = x
mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
, hswc_wcs = PlaceHolder
, hswc_ctx = Nothing }
, hswc_wcs = PlaceHolder }
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
......@@ -362,8 +357,7 @@ mkEmptyImplicitBndrs x = HsIB { hsib_body = x
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x
, hswc_wcs = []
, hswc_ctx = Nothing }
, hswc_wcs = [] }
--------------------------------------------------
......@@ -789,8 +783,8 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name]
-- - the named wildcars; see Note [Scoping of named wildcards]
-- because they scope in the same way
hsWcScopedTvs sig_ty
| HsIB { hsib_vars = vars, hsib_body = sig_ty1 } <- sig_ty
, HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1
| HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty
, HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
map hsLTyVarName tvs
......@@ -1237,10 +1231,10 @@ ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) = char '_'
ppr_mono_ty _ (HsWildCardTy {}) = char '_'
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
= maybeParen ctxt_prec TyOpPrec $
......
......@@ -564,7 +564,7 @@ mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig
......
This diff is collapsed.
This diff is collapsed.
......@@ -20,8 +20,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
import HsSyn
import TcEnv
import TcPat( addInlinePrags, lookupPragEnv, emptyPragEnv )
import TcEvidence( idHsWrapper )
import TcSigs
import TcEvidence ( idHsWrapper )
import TcBinds
import TcUnify
import TcHsType
......@@ -152,10 +152,10 @@ tcClassSigs clas sigs def_methods
tcClassDecl2 :: LTyClDecl Name -- The class declaration
-> TcM (LHsBinds Id)
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
setSrcSpan loc $
setSrcSpan (getLoc class_name) $
do { clas <- tcLookupLocatedClass class_name
-- We make a separate binding for each default method.
......@@ -203,7 +203,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
= do { -- First look up the default method -- It should be there!
global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags
; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
-- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
......@@ -241,26 +241,27 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
ctxt = FunSigCtxt sel_name warn_redundant
; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty local_dm_name
; (ev_binds, (tc_bind, _))
; let local_dm_id = mkLocalId local_dm_name local_dm_ty
local_dm_sig = CompleteSig { sig_bndr = local_dm_id
, sig_ctxt = ctxt
, sig_loc = getLoc (hsSigType hs_ty) }
; (ev_binds, (tc_bind, _))
<- checkConstraints (ClsSkol clas) tyvars [this_dict] $
tcPolyCheck NonRecursive no_prag_fn local_dm_sig
tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind)
; let export = ABE { abe_poly = global_dm_id
-- We have created a complete type signature in
-- instTcTySig, hence it is safe to call
-- completeSigPolyId
, abe_mono = completeIdSigPolyId local_dm_sig
, abe_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
, abs_exports = [export]
, abs_ev_binds = [ev_binds]
, abs_binds = tc_bind }
; return (unitBag (L bind_loc full_bind)) }
; let export = ABE { abe_poly = global_dm_id
, abe_mono = local_dm_id
, abe_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
full_bind = AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
, abs_exports = [export]
, abs_ev_binds = [ev_binds]
, abs_binds = tc_bind }
; return (unitBag (L bind_loc full_bind)) }
| otherwise = pprPanic "tcDefMeth" (ppr sel_id)
where
......
......@@ -60,7 +60,7 @@ module TcEnv(
topIdLvl, isBrackStage,
-- New Ids
newLocalName, newDFunName, newDFunName', newFamInstTyConName,
newDFunName, newDFunName', newFamInstTyConName,
newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
mkWrapperName
......
......@@ -1545,7 +1545,7 @@ suggestAddSig ctxt ty1 ty2
inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
get_inf ty | Just tv <- tcGetTyVar_maybe ty
, isSkolemTyVar tv
, (_, InferSkol prs) <- getSkolemInfo (cec_encl ctxt) tv
, InferSkol prs <- ic_info (getSkolemInfo (cec_encl ctxt) tv)
= map fst prs
| otherwise
= []
......@@ -2477,17 +2477,18 @@ mkAmbigMsg prepend_msg ct
pprSkol :: [Implication] -> TcTyVar -> SDoc
pprSkol implics tv
| (skol_tvs, skol_info) <- getSkolemInfo implics tv
= case skol_info of
UnkSkol -> pp_tv <+> text "is an unknown type variable"
UnkSkol -> quotes (ppr tv) <+> text "is an unknown type variable"
SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt
(mkSpecForAllTys skol_tvs ty))
_ -> ppr_rigid (pprSkolInfo skol_info)
where
pp_tv = quotes (ppr tv)
ppr_rigid pp_info = hang (pp_tv <+> text "is a rigid type variable bound by")
2 (sep [ pp_info
, text "at" <+> ppr (getSrcLoc tv) ])
Implic { ic_skols = skol_tvs, ic_info = skol_info }
= getSkolemInfo implics tv
ppr_rigid pp_info
= hang (quotes (ppr tv) <+> text "is a rigid type variable bound by")
2 (sep [ pp_info
, text "at" <+> ppr (getSrcSpan tv) ])
getAmbigTkvs :: Ct -> ([Var],[Var])
getAmbigTkvs ct
......@@ -2497,15 +2498,14 @@ getAmbigTkvs ct
ambig_tkvs = filter isAmbiguousTyVar tkvs
dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
getSkolemInfo :: [Implication] -> TcTyVar -> ([TcTyVar], SkolemInfo)
getSkolemInfo :: [Implication] -> TcTyVar -> Implication
-- Get the skolem info for a type variable
-- from the implication constraint that binds it
getSkolemInfo [] tv
= pprPanic "No skolem info:" (ppr tv)
getSkolemInfo (implic:implics) tv
| let skols = ic_skols implic
, tv `elem` ic_skols implic = (skols, ic_info implic)
| tv `elem` ic_skols implic = implic
| otherwise = getSkolemInfo implics tv
-----------------------
......
......@@ -27,8 +27,8 @@ import TcRnMonad
import TcUnify
import BasicTypes
import Inst
import TcBinds ( chooseInferredQuantifiers, tcLocalBinds
, tcUserTypeSig, tcExtendTyVarEnvFromSig )
import TcBinds ( chooseInferredQuantifiers, tcLocalBinds )
import TcSigs ( tcUserTypeSig, tcInstSig )
import TcSimplify ( simplifyInfer )
import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
import FamInstEnv ( FamInstEnvs )
......@@ -256,8 +256,9 @@ tcExpr e@(HsLamCase matches) res_ty
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
tcExpr e@(ExprWithTySig expr sig_ty) res_ty
= do { sig_info <- checkNoErrs $ -- Avoid error cascade
tcUserTypeSig sig_ty Nothing
= do { let loc = getLoc (hsSigWcType sig_ty)
; sig_info <- checkNoErrs $ -- Avoid error cascade
tcUserTypeSig loc sig_ty Nothing
; (expr', poly_ty) <- tcExprSig expr sig_info
; let expr'' = ExprWithTySigOut expr' sig_ty
; tcWrapResult e expr'' poly_ty res_ty }
......@@ -880,12 +881,13 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
; let result_inst_tys = mkTyVarTys con1_tvs'
init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTCvSubst
; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
(con1_tvs `zip` result_inst_tys)
; let rec_res_ty = TcType.substTy result_subst con1_res_ty
scrut_ty = TcType.substTyUnchecked scrut_subst con1_res_ty
scrut_ty = TcType.substTy scrut_subst con1_res_ty
con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
......@@ -1443,20 +1445,14 @@ in the other order, the extra signature in f2 is reqd.
********************************************************************* -}
tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType)
tcExprSig expr sig@(TISI { sig_bndr = s_bndr
, sig_skols = skol_prs
, sig_theta = theta
, sig_tau = tau })
| null skol_prs -- Fast path when there is no quantification at all
, null theta
, CompleteSig {} <- s_bndr
= do { expr' <- tcPolyExprNC expr tau
; return (expr', tau) }
| CompleteSig poly_id <- s_bndr
= do { given <- newEvVars theta
tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
= setSrcSpan loc $ -- Sets the location for the implication constraint
do { (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars loc) poly_id
; given <- newEvVars theta
; let skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
skol_tvs = map snd tv_prs
; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
tcExtendTyVarEnvFromSig sig $
tcExtendTyVarEnv2 tv_prs $
tcPolyExprNC expr tau
; let poly_wrap = mkWpTyLams skol_tvs
......@@ -1464,20 +1460,26 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', idType poly_id) }
| PartialSig { sig_name = name, sig_wcs = wc_prs, sig_hs_ty = hs_ty } <- s_bndr
= do { (tclvl, wanted, expr')
tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
= setSrcSpan loc $ -- Sets the location for the implication constraint
do { (tclvl, wanted, (expr', sig_inst))
<- pushLevelAndCaptureConstraints $
tcExtendTyVarEnvFromSig sig $
do { addErrCtxt (pprSigCtxt ExprSigCtxt (ppr hs_ty)) $
emitWildCardHoleConstraints wc_prs
; tcPolyExprNC expr tau }
do { sig_inst <- tcInstSig sig
; expr' <- tcExtendTyVarEnv2 (sig_inst_skols sig_inst) $
tcExtendTyVarEnv2 (sig_inst_wcs sig_inst) $
tcPolyExprNC expr (sig_inst_tau sig_inst)
; return (expr', sig_inst) }
-- See Note [Partial expression signatures]
; let tau = sig_inst_tau sig_inst
mr = null (sig_inst_theta sig_inst) &&
isNothing (sig_inst_wcx sig_inst)
; (qtvs, givens, ev_binds)
<- simplifyInfer tclvl False [sig] [(name, tau)] wanted
<- simplifyInfer tclvl mr [sig_inst] [(name, tau)] wanted
; tau <- zonkTcType tau
; let inferred_theta = map evVarPred givens
tau_tvs = tyCoVarsOfType tau
; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
tau_tvs qtvs (Just sig)
tau_tvs qtvs (Just sig_inst)
; let inferred_sigma = mkInvSigmaTy qtvs inferred_theta tau
my_sigma = mkForAllTys binders (mkPhiTy my_theta tau)
; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
......@@ -1494,10 +1496,34 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', my_sigma) }
| otherwise = panic "tcExprSig" -- Can't happen
where
skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
skol_tvs = map snd skol_prs
{- Note [Partial expression signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Partial type signatures on expressions are easy to get wrong. But
here is a guiding principile
e :: ty
should behave like
let x :: ty
x = e
in x
So for partial signatures we apply the MR if no context is given. So
e :: IO _ apply the MR
e :: _ => IO _ do not apply the MR
just like in TcBinds.decideGeneralisationPlan
This makes a difference (Trac #11670):
peek :: Ptr a -> IO CLong
peek ptr = peekElemOff undefined 0 :: _
from (peekElemOff undefined 0) we get
type: IO w
constraints: Storable w
We must NOT try to generalise over 'w' because the signature specifies
no constraints so we'll complain about not being able to solve
Storable w. Instead, don't generalise; then _ gets instantiated to
CLong, as it should.
-}
{- *********************************************************************
* *
......
This diff is collapsed.
......@@ -18,7 +18,7 @@ import TcTyClsDecls
import TcClassDcl( tcClassDecl2, tcATDefault,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod )
import TcPat ( addInlinePrags, lookupPragEnv, emptyPragEnv )
import TcSigs
import TcRnMonad
import TcValidity
import TcHsSyn ( zonkTcTypeToTypes, emptyZonkEnv )
......@@ -761,7 +761,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id
; dfun_ev_vars <- newEvVars dfun_theta
-- We instantiate the dfun_id with superSkolems.
-- See Note [Subtle interaction of recursion and overlap]
......@@ -1349,7 +1349,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
sig_fn (spec_inst_prags, prag_fn)
sel_id (L bind_loc meth_bind) bndr_loc
= add_meth_ctxt $
do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id))
do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
......@@ -1396,7 +1396,8 @@ tcMethodBodyHelp sig_fn sel_id local_meth_id meth_bind
| Just hs_sig_ty <- lookupHsSig sig_fn sel_name
-- There is a signature in the instance
-- See Note [Instance method signatures]
= do { (sig_ty, hs_wrap)
= do { let ctxt = FunSigCtxt sel_name True
; (sig_ty, hs_wrap)
<- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
do { inst_sigs <- xoptM LangExt.InstanceSigs
; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
......@@ -1408,8 +1409,13 @@ tcMethodBodyHelp sig_fn sel_id local_meth_id meth_bind
; return (sig_ty, hs_wrap) }
; inner_meth_name <- newName (nameOccName sel_name)
; tc_sig <- instTcTySig ctxt hs_sig_ty sig_ty inner_meth_name
; (tc_bind, [inner_id]) <- tcPolyCheck NonRecursive no_prag_fn tc_sig meth_bind
; let inner_meth_id = mkLocalId inner_meth_name sig_ty
inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
, sig_ctxt = ctxt
, sig_loc = getLoc (hsSigType hs_sig_ty) }
; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
; let export = ABE { abe_poly = local_meth_id
, abe_mono = inner_id
......@@ -1422,7 +1428,10 @@ tcMethodBodyHelp sig_fn sel_id local_meth_id meth_bind
, abs_binds = tc_bind, abs_ev_binds = [] }) }
| otherwise -- No instance signature
= do { tc_sig <- instTcTySigFromId local_meth_id
= do { let ctxt = FunSigCtxt sel_name False
-- False <=> don't report redundant constraints
-- The signature is not under the users control!
tc_sig = completeSigFromId ctxt local_meth_id
-- Absent a type sig, there are no new scoped type variables here
-- Only the ones from the instance decl itself, which are already
-- in scope. Example:
......@@ -1430,11 +1439,10 @@ tcMethodBodyHelp sig_fn sel_id local_meth_id meth_bind
-- instance C [c] where { op = <rhs> }
-- In <rhs>, 'c' is scope but 'b' is not!
; (tc_bind, _) <- tcPolyCheck NonRecursive no_prag_fn tc_sig meth_bind
; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
; return tc_bind }
where
ctxt = FunSigCtxt sel_name True
sel_name = idName sel_id
no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
-- they are all for meth_id
......
......@@ -51,12 +51,12 @@ module TcMType (
--------------------------------
-- Instantiation
newMetaTyVars, newMetaTyVarX, newMetaSigTyVars,
newSigTyVar,
newMetaTyVars, newMetaTyVarX,
newMetaSigTyVars, newMetaSigTyVarX,
newSigTyVar, newWildCardX,
tcInstType,
tcInstSkolTyVars, tcInstSkolTyVarsLoc, tcInstSuperSkolTyVarsX,
tcInstSigTyVarsLoc, tcInstSigTyVars,
tcInstSkolType,
tcInstSkolTyVars, tcInstSuperSkolTyVarsX,
tcInstSigTyVars,
tcSkolDFunType, tcSuperSkolTyVars,
instSkolTyCoVars, freshenTyVarBndrs, freshenCoVarBndrsX,
......@@ -433,11 +433,11 @@ inferTypeToType u tc_lvl ki ref
tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
-- ^ How to instantiate the type variables
-> TcType -- ^ Type to instantiate
-> TcM ([TcTyVar], TcThetaType, TcType) -- ^ Result
-> Id -- ^ Type to instantiate
-> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result
-- (type vars, preds (incl equalities), rho)
tcInstType inst_tyvars ty
= case tcSplitForAllTys ty of
tcInstType inst_tyvars id
= case tcSplitForAllTys (idType id) of
([], rho) -> let -- There may be overloading despite no type variables;
-- (?x :: Int) => Int -> Int
(theta, tau) = tcSplitPhiTy rho
......@@ -446,12 +446,15 @@ tcInstType inst_tyvars ty
(tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars
; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)
; return (tyvars', theta, tau) }
tv_prs = map tyVarName tyvars `zip` tyvars'
; return (tv_prs, theta, tau) }
tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType)
tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type signature with skolem constants.
-- We could give them fresh names, but no need to do so
tcSkolDFunType ty = tcInstType tcInstSuperSkolTyVars ty
tcSkolDFunType dfun
= do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun
; return (map snd tv_prs, theta, tau) }
tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
-- Make skolem constants, but do *not* give them new names, as above
......@@ -467,11 +470,6 @@ tcSuperSkolTyVar subst tv
kind = substTyUnchecked subst (tyVarKind tv)
new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
-- Wrappers
-- we need to be able to do this from outside the TcM monad:
tcInstSkolTyVarsLoc :: SrcSpan -> [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TcTyVar])
tcInstSkolTyVarsLoc loc = instSkolTyCoVars (mkTcSkolTyVar loc False)
-- | Given a list of @['TyVar']@, skolemize the type variables,
-- returning a substitution mapping the original tyvars to the
-- skolems, and the list of newly bound skolems. See also
......@@ -501,23 +499,9 @@ mkTcSkolTyVar loc overlappable uniq old_name kind
kind
(SkolemTv overlappable)
tcInstSigTyVarsLoc :: SrcSpan -> [TyVar]
-> TcRnIf gbl lcl (TCvSubst, [TcTyVar])
-- We specify the location
tcInstSigTyVarsLoc loc = instSkolTyCoVars (mkTcSkolTyVar loc False)
tcInstSigTyVars :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TcTyVar])
-- Get the location from the TyVar itself, not the monad
tcInstSigTyVars
= instSkolTyCoVars mk_tv
where
mk_tv uniq old_name kind
= mkTcTyVar (setNameUnique old_name uniq) kind (SkolemTv False)
tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type with fresh skolem constants
-- Binding location comes from the monad
tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
tcInstSigTyVars :: SrcSpan -> [TyVar]
-> TcRnIf gbl lcl (TCvSubst, [TcTyVar])
tcInstSigTyVars loc = instSkolTyCoVars (mkTcSkolTyVar loc False)
------------------
freshenTyVarBndrs :: [TyVar] -> TcRnIf gbl lcl (TCvSubst, [TyVar])
......@@ -793,13 +777,18 @@ newMetaSigTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
-- Just like newMetaTyVarX, but make a SigTv
newMetaSigTyVarX subst tyvar = new_meta_tv_x SigTv subst tyvar
newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
newWildCardX subst tv
= do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))
; return (extendTvSubstWithClone subst tv new_tv, new_tv) }
new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
new_meta_tv_x info subst tyvar