{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
-module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
+module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
tcHsBootSigs, tcPolyCheck,
addTypecheckedBinds,
chooseInferredQuantifiers,
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
-import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
- , tcPatSynBuilderBind )
+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
import CoreSyn (Tickish (..))
import CostCentre (mkUserCC, CCFlavour(DeclCC))
import DynFlags
<+> quotes (ppr tc'))
in mapMaybeM (addLocM doOne) sigs
-tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv
-tcRecSelBinds (XValBindsLR (NValBinds binds sigs))
- = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $
- do { (rec_sel_binds, tcg_env) <- discardWarnings $
- tcValBinds TopLevel binds sigs getGblEnv
- ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds
- ; return tcg_env' }
-tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds"
-
tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it. The renamer checked all this
where
tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
where
- f (L _ name)
+ f (dL->L _ name)
= do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
; return (mkVanillaGlobal name sigma_ty) }
-- Notice that we make GlobalIds, not LocalIds
; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
where
- ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds]
+ ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]
-- I wonder if we should do these one at at time
-- Consider ?x = 4
-- ?y = ?x + 1
- tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr)
+ tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)
= do { ty <- newOpenFlexiTyVarTy
; let p = mkStrLitTy $ hsIPNameFS ip
; ip_id <- newDict ipClass [ p, ty ]
; let d = toDict ipClass p ty `fmap` expr'
; return (ip_id, (IPBind noExt (Right ip_id) d)) }
tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
- tc_ip_bind _ (XCIPBind _) = panic "tc_ip_bind"
+ tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"
-- Coerces a `t` into a dictionry for `IP "x" t`.
-- co : t -> IP "x" t
-> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
tcValBinds top_lvl binds sigs thing_inside
- = do { let patsyns = getPatSynBinds binds
-
- -- Typecheck the signature
+ = do { -- Typecheck the signatures
+ -- It's easier to do so now, once for all the SCCs together
+ -- because a single signature f,g :: <type>
+ -- might relate to more than one SCC
; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
tcTySigs sigs
- ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
-
-- Extend the envt right away with all the Ids
-- declared with complete type signatures
-- Do not extend the TcBinderStack; instead
; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
+ where
+ patsyns = getPatSynBinds binds
+ prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
tc_sub_group rec_tc binds =
tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
-recursivePatSynErr :: OutputableBndrId name => LHsBinds name -> TcM a
+recursivePatSynErr :: OutputableBndrId (GhcPass p) =>
+ LHsBinds (GhcPass p) -> TcM a
recursivePatSynErr binds
= failWithTc $
hang (text "Recursive pattern synonym definition with following bindings:")
2 (vcat $ map pprLBind . bagToList $ binds)
where
pprLoc loc = parens (text "defined at" <+> ppr loc)
- pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
- pprLoc loc
+ pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)
+ <+> pprLoc loc
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind GhcRn -> IsGroupClosed -> TcM thing
-> TcM (LHsBinds GhcTcId, thing)
tc_single _top_lvl sig_fn _prag_fn
- (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
+ (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) }))
_ thing_inside
- = do { (aux_binds, tcg_env) <- tc_pat_syn_decl
+ = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
; thing <- setGblEnv tcg_env thing_inside
; return (aux_binds, thing)
}
- where
- tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv)
- tc_pat_syn_decl = case sig_fn name of
- Nothing -> tcInferPatSynDecl psb
- Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
- Just _ -> panic "tc_single"
tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
= do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
keyd_binds = bagToList binds `zip` [0::BKey ..]
key_map :: NameEnv BKey -- Which binding it comes from
- key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
+ key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds
, bndr <- collectHsBindBinders bind ]
------------------------
= mkLocalId name forall_a_a
forall_a_a :: TcType
-forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
+-- At one point I had (forall r (a :: TYPE r). a), but of course
+-- that type is ill-formed: its mentions 'r' which escapes r's scope.
+-- Another alternative would be (forall (a :: TYPE kappa). a), where
+-- kappa is a unification variable. But I don't think we need that
+-- complication here. I'm going to just use (forall (a::*). a).
+-- See #15276
+forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
{- *********************************************************************
* *
(CompleteSig { sig_bndr = poly_id
, sig_ctxt = ctxt
, sig_loc = sig_loc })
- (L loc (FunBind { fun_id = L nm_loc name
- , fun_matches = matches }))
+ (dL->L loc (FunBind { fun_id = (dL->L nm_loc name)
+ , fun_matches = matches }))
= setSrcSpan sig_loc $
do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
; (ev_binds, (co_fn, matches'))
<- checkConstraints skol_info skol_tvs ev_vars $
tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
- tcExtendTyVarEnv2 tv_prs $
+ tcExtendNameTyVarEnv tv_prs $
setSrcSpan loc $
- tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
+ tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)
; let prag_sigs = lookupPragEnv prag_fn name
; spec_prags <- tcSpecPrags poly_id prag_sigs
; mod <- getModule
; tick <- funBindTicks nm_loc mono_id mod prag_sigs
- ; let bind' = FunBind { fun_id = L nm_loc mono_id
+ ; let bind' = FunBind { fun_id = cL nm_loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn
, fun_ext = placeHolderNamesTc
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags }
- abs_bind = L loc $
+ abs_bind = cL loc $
AbsBinds { abs_ext = noExt
, abs_tvs = skol_tvs
, abs_ev_vars = ev_vars
, abs_ev_binds = [ev_binds]
, abs_exports = [export]
- , abs_binds = unitBag (L loc bind')
+ , abs_binds = unitBag (cL loc bind')
, abs_sig = True }
; return (unitBag abs_bind, [poly_id]) }
funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-> TcM [Tickish TcId]
funBindTicks loc fun_id mod sigs
- | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]
+ | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]
-- this can only be a singleton list, as duplicate pragmas are rejected
-- by the renamer
, let cc_str
; mapM_ (checkOverloadedSig mono) sigs
; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
- ; (qtvs, givens, ev_binds, insoluble)
+ ; (qtvs, givens, ev_binds, residual, insoluble)
<- simplifyInfer tclvl infer_mode sigs name_taus wanted
+ ; emitConstraints residual
; let inferred_theta = map evVarPred givens
; exports <- checkNoErrs $
; loc <- getSrcSpanM
; let poly_ids = map abe_poly exports
- abs_bind = L loc $
+ abs_bind = cL loc $
AbsBinds { abs_ext = noExt
, abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = [ev_binds]
checkValidType (InfSigCtxt poly_name) inferred_poly_ty
-- See Note [Validity of inferred types]
-- If we found an insoluble error in the function definition, don't
- -- do this check; otherwise (Trac #14000) we may report an ambiguity
+ -- do this check; otherwise (#14000) we may report an ambiguity
-- error for a rather bogus type.
; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
= -- No type signature (partial or complete) for this binder,
do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
- -- Include kind variables! Trac #7916
+ -- Include kind variables! #7916
my_theta = pickCapturedPreds free_tvs inferred_theta
binders = [ mkTyVarBinder Inferred tv
| tv <- qtvs
, sig_inst_theta = annotated_theta
, sig_inst_skols = annotated_tvs }))
= -- Choose quantifiers for a partial type signature
- do { psig_qtv_prs <- zonkSigTyVarPairs annotated_tvs
+ do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs
-- Check whether the quantified variables of the
-- partial signature have been unified together
-- See Note [Quantified variables in partial type signatures]
- ; mapM_ report_dup_sig_tv_err (findDupSigTvs psig_qtv_prs)
+ ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs)
-- Check whether a quantified variable of the partial type
-- signature is not actually quantified. How can that happen?
; return (final_qtvs, my_theta) }
where
- report_dup_sig_tv_err (n1,n2)
+ report_dup_tyvar_tv_err (n1,n2)
| PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
= addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
<+> text "with" <+> quotes (ppr n2))
2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
| otherwise -- Can't happen; by now we know it's a partial sig
- = pprPanic "report_sig_tv_err" (ppr sig)
+ = pprPanic "report_tyvar_tv_err" (ppr sig)
report_mono_sig_tv_err n
| PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
2 (hang (text "bound by the partial type signature:")
2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
| otherwise -- Can't happen; by now we know it's a partial sig
- = pprPanic "report_sig_tv_err" (ppr sig)
+ = pprPanic "report_mono_sig_tv_err" (ppr sig)
choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-> TcM (VarSet, TcThetaType)
-- K f = e
-- The MR applies, but the signature is overloaded, and it's
-- best to complain about this directly
--- c.f Trac #11339
+-- c.f #11339
checkOverloadedSig monomorphism_restriction_applies sig
| not (null (sig_inst_theta sig))
, monomorphism_restriction_applies
way to get per-binding inferred generalisation.
We apply the MR if /all/ of the partial signatures lack a context.
-In particular (Trac #11016):
+In particular (#11016):
f2 :: (?loc :: Int) => _
f2 = ?loc
It's stupid to apply the MR here. This test includes an extra-constraints
g x y = [x, y]
Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
-together, which is fine. So we bind 'a' and 'b' to SigTvs, which can then
+together, which is fine. So we bind 'a' and 'b' to TyVarTvs, which can then
unify with each other.
But now consider:
We want to get an error from this, because 'a' and 'b' get unified.
So we make a test, one per parital signature, to check that the
explicitly-quantified type variables have not been unified together.
-Trac #14449 showed this up.
+#14449 showed this up.
Note [Validity of inferred types]
forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype
and the proof is the impedance matcher.
-Notice that the impedance matcher may do defaulting. See Trac #7173.
+Notice that the impedance matcher may do defaulting. See #7173.
It also cleverly does an ambiguity check; for example, rejecting
f :: F a -> F a
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTcId, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
- [ L b_loc (FunBind { fun_id = L nm_loc name,
- fun_matches = matches, fun_ext = fvs })]
+ [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name)
+ , fun_matches = matches
+ , fun_ext = fvs })]
-- Single function binding,
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature
do { ((co_fn, matches'), rhs_ty)
<- tcInferInst $ \ exp_ty ->
-- tcInferInst: see TcUnify,
- -- Note [Deep instantiation of InferResult]
+ -- Note [Deep instantiation of InferResult] in TcUnify
tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-- We extend the error context even for a non-recursive
-- function so that in type error messages we show the
-- type of the thing whose rhs we are type checking
- tcMatchesFun (L nm_loc name) matches exp_ty
+ tcMatchesFun (cL nm_loc name) matches exp_ty
; mono_id <- newLetBndr no_gen name rhs_ty
- ; return (unitBag $ L b_loc $
- FunBind { fun_id = L nm_loc mono_id,
+ ; return (unitBag $ cL b_loc $
+ FunBind { fun_id = cL nm_loc mono_id,
fun_matches = matches', fun_ext = fvs,
fun_co_fn = co_fn, fun_tick = [] },
[MBI { mbi_poly_name = name
-- CheckGen is used only for functions with a complete type signature,
-- and tcPolyCheck doesn't use tcMonoBinds at all
-tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches })
+tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name)
+ , fun_matches = matches })
| Just (TcIdSig sig) <- sig_fn name
= -- There is a type signature.
-- It must be partial; if complete we'd be in tcPolyCheck!
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))
+ ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id))
matches (mkCheckExpType $ idType mono_id)
- ; return ( FunBind { fun_id = L loc mono_id
+ ; return ( FunBind { fun_id = cL loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn
, fun_ext = placeHolderNamesTc
tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
tcExtendTyVarEnvFromSig sig_inst thing_inside
| TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
- -- Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
- = tcExtendTyVarEnv2 wcs $
- tcExtendTyVarEnv2 skol_prs $
+ = tcExtendNameTyVarEnv wcs $
+ tcExtendNameTyVarEnv skol_prs $
thing_inside
tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Look at:
- typecheck/should_compile/ExPat
- - Trac #12427, typecheck/should_compile/T12427{a,b}
+ - #12427, typecheck/should_compile/T12427{a,b}
data T where
MkT :: Integral a => a -> Int -> T
CheckGen), then the let_bndr_spec will be LetLclBndr. In that case
we want to bind a cloned, local version of the variable, with the
type given by the pattern context, *not* by the signature (even if
- there is one; see Trac #7268). The mkExport part of the
+ there is one; see #7268). The mkExport part of the
generalisation step will do the checking and impedance matching
against the signature.
Example for (E2), we generate
q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
-The beta is untoucable, but floats out of the constraint and can
+The beta is untouchable, but floats out of the constraint and can
be solved absolutely fine.
-Note [Use tcExtendTyVar not scopeTyVars in tcRhs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Normally, any place that corresponds to Λ or ∀ in Core should be flagged
-with a call to scopeTyVars, which arranges for an implication constraint
-to be made, bumps the TcLevel, and (crucially) prevents a unification
-variable created outside the scope of a local skolem to unify with that
-skolem.
-
-We do not need to do this here, however.
-
-- Note that this happens only in the case of a partial signature.
- Complete signatures go via tcPolyCheck, not tcPolyInfer.
-
-- The TcLevel is incremented in tcPolyInfer, right outside the call
- to tcMonoBinds. We thus don't have to worry about outer metatvs unifying
- with local skolems.
-
-- The other potential concern is that we need SkolemInfo associated with
- the skolems. This, too, is OK, though: the constraints pass through
- simplifyInfer (which doesn't report errors), at the end of which
- the skolems will get quantified and put into an implication constraint.
- Thus, by the time any errors are reported, the SkolemInfo will be
- in place.
************************************************************************
* *
= [ null theta
| TcIdSig (PartialSig { psig_hs_ty = hs_ty })
<- mapMaybe sig_fn (collectHsBindListBinders lbinds)
- , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
+ , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
has_partial_sigs = not (null partial_sig_mrs)
-- With OutsideIn, all nested bindings are monomorphic
-- except a single function binding with a signature
one_funbind_with_sig
- | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
+ | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds
, Just (TcIdSig sig) <- sig_fn (unLoc v)
= Just (lbind, sig)
| otherwise
fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
- bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs })
+ bindFvs (FunBind { fun_id = (dL->L _ f)
+ , fun_ext = fvs })
= let open_fvs = get_open_fvs fvs
in [(f, open_fvs)]
bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
git.haskell.org / ghc.git / blobdiff