\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
- findMethodBind, tcMethodBind,
+ findMethodBind, tcInstanceMethodBody,
mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
import InstEnv
import TcEnv
import TcBinds
+import TcSimplify
import TcHsType
import TcMType
import TcType
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return (emptyLHsBinds, [])) $
- setSrcSpan loc $ do
- clas <- tcLookupLocatedClass class_name
+ setSrcSpan loc $
+ do { clas <- tcLookupLocatedClass class_name
-- We make a separate binding for each default method.
-- At one time I used a single AbsBinds for all of them, thus
-- dm1 = \d -> case ds d of (a,b,c) -> a
-- And since ds is big, it doesn't get inlined, so we don't get good
-- default methods. Better to make separate AbsBinds for each
- let
- (tyvars, _, _, op_items) = classBigSig clas
- rigid_info = ClsSkol clas
- prag_fn = mkPragFun sigs
- sig_fn = mkTcSigFun sigs
- clas_tyvars = tcSkolSigTyVars rigid_info tyvars
- tc_dm = tcDefMeth clas_tyvars default_binds
- sig_fn prag_fn
- -- tc_dm is called only for a sel_id
- -- that has a binding in default_binds
-
- dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
- -- Generate code for polymorphic default methods only
- -- (Generic default methods have turned into instance decls by now.)
- -- This is incompatible with Hugs, which expects a polymorphic
- -- default method for every class op, regardless of whether or not
- -- the programmer supplied an explicit default decl for the class.
- -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-
- (defm_binds, dm_ids) <- mapAndUnzipM tc_dm dm_sel_ids
- return (unionManyBags defm_binds, dm_ids)
+ ; let
+ (tyvars, _, _, op_items) = classBigSig clas
+ rigid_info = ClsSkol clas
+ prag_fn = mkPragFun sigs
+ sig_fn = mkTcSigFun sigs
+ clas_tyvars = tcSkolSigTyVars rigid_info tyvars
+ pred = mkClassPred clas (mkTyVarTys clas_tyvars)
+ ; inst_loc <- getInstLoc (SigOrigin rigid_info)
+ ; this_dict <- newDictBndr inst_loc pred
+
+ ; let tc_dm = tcDefMeth rigid_info clas clas_tyvars [pred]
+ this_dict default_binds
+ sig_fn prag_fn
+ -- tc_dm is called only for a sel_id
+ -- that has a binding in default_binds
+
+ dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
+ -- Generate code for polymorphic default methods only (hence DefMeth)
+ -- (Generic default methods have turned into instance decls by now.)
+ -- This is incompatible with Hugs, which expects a polymorphic
+ -- default method for every class op, regardless of whether or not
+ -- the programmer supplied an explicit default decl for the class.
+ -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
+
+ ; (defm_binds, dm_ids) <- tcExtendTyVarEnv clas_tyvars $
+ mapAndUnzipM tc_dm dm_sel_ids
+
+ ; return (unionManyBags defm_binds, dm_ids) }
+
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-tcDefMeth :: [TyVar] -> LHsBinds Name
+tcDefMeth :: SkolemInfo -> Class -> [TyVar] -> ThetaType -> Inst -> LHsBinds Name
-> TcSigFun -> TcPragFun -> Id
-> TcM (LHsBinds Id, Id)
-tcDefMeth tyvars binds_in sig_fn prag_fn sel_id
+tcDefMeth rigid_info clas tyvars theta this_dict binds_in sig_fn prag_fn sel_id
= do { let sel_name = idName sel_id
- ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
- ; uniq <- newUnique
- ; let dm_ty = idType sel_id -- Same as dict selector!
- local_dm_name = setNameUnique sel_name uniq
- local_dm_id = mkLocalId local_dm_name dm_ty
- top_dm_id = mkDefaultMethodId dm_name dm_ty
- all_tvs = map tyVarName tyvars ++ (sig_fn sel_name `orElse` [])
- -- Tyvars in scope are *both* the ones from the
- -- class decl *and* ones from the method sig
-
+ ; local_dm_name <- newLocalName sel_name
; let meth_bind = findMethodBind sel_name local_dm_name binds_in
`orElse` pprPanic "tcDefMeth" (ppr sel_id)
-- We only call tcDefMeth on selectors for which
-- there is a binding in binds_in
- ; tc_meth_bind <- tcMethodBind all_tvs (prag_fn sel_name)
- local_dm_id meth_bind
+ meth_sig_fn _ = sig_fn sel_name
+ meth_prag_fn _ = prag_fn sel_name
- -- See Note [Silly default-method bind]
- ; let loc = getLoc meth_bind
- top_bind = L loc $ VarBind top_dm_id $
- L loc $ HsWrap (WpLet tc_meth_bind) $
- HsVar local_dm_id
+ ; (top_dm_id, bind) <- tcInstanceMethodBody rigid_info
+ clas tyvars [this_dict] theta (mkTyVarTys tyvars)
+ Nothing sel_id
+ local_dm_name
+ meth_sig_fn meth_prag_fn
+ meth_bind
- ; return (unitBag top_bind, top_dm_id) }
+ ; return (bind, top_dm_id) }
mkDefMethRdrName :: Name -> RdrName
mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
= Just (L loc1 (bind { fun_id = L loc2 meth_name }))
f _other = Nothing
----------------------------
-tcMethodBind :: [Name] -> [LSig Name] -> Id
- -> LHsBind Name -> TcM (LHsBinds Id)
-tcMethodBind tyvars prags meth_id bind
- = do { let sig_fn _ = Just tyvars
- prag_fn _ = prags
+---------------
+tcInstanceMethodBody :: SkolemInfo -> Class -> [TcTyVar] -> [Inst]
+ -> TcThetaType -> [TcType]
+ -> Maybe (Inst, LHsBind Id) -> Id
+ -> Name -- The local method name
+ -> TcSigFun -> TcPragFun -> LHsBind Name
+ -> TcM (Id, LHsBinds Id)
+tcInstanceMethodBody rigid_info clas tyvars dfun_dicts theta inst_tys
+ mb_this_bind sel_id local_meth_name
+ sig_fn prag_fn bind@(L loc _)
+ = do { let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
+ rho_ty = ASSERT( length sel_tyvars == length inst_tys )
+ substTyWith sel_tyvars inst_tys sel_rho
+
+ (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
+ `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+
+ local_meth_id = mkLocalId local_meth_name local_meth_ty
+ meth_ty = mkSigmaTy tyvars theta local_meth_ty
+ sel_name = idName sel_id
+
+ -- The first predicate should be of form (C a b)
+ -- where C is the class in question
+ ; MASSERT( case getClassPredTys_maybe first_pred of
+ { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
-- Typecheck the binding, first extending the envt
- -- so that when tcInstSig looks up the meth_id to find
- -- its signature, we'll find it in the environment
- --
- -- If scoped type variables is on, they are brought
- -- into scope by tcPolyBinds (via sig_fn)
- --
- -- See Note [Polymorphic methods]
- ; traceTc (text "tcMethodBind" <+> ppr meth_id <+> ppr tyvars)
- ; (tc_binds, ids) <- tcExtendIdEnv [meth_id] $
- tcPolyBinds TopLevel sig_fn prag_fn
- NonRecursive NonRecursive
- (unitBag bind)
-
- ; ASSERT( ids == [meth_id] ) -- Binding for ONE method
- return tc_binds }
+ -- so that when tcInstSig looks up the local_meth_id to find
+ -- its signature, we'll find it in the environment
+ ; ((tc_bind, _), lie) <- getLIE $
+ tcExtendIdEnv [local_meth_id] $
+ tcPolyBinds TopLevel sig_fn prag_fn
+ NonRecursive NonRecursive
+ (unitBag bind)
+
+ ; meth_id <- case rigid_info of
+ ClsSkol _ -> do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
+ ; return (mkDefaultMethodId dm_name meth_ty) }
+ _other -> do { meth_name <- newLocalName sel_name
+ ; return (mkLocalId meth_name meth_ty) }
+
+ ; let (avails, this_dict_bind)
+ = case mb_this_bind of
+ Nothing -> (dfun_dicts, emptyBag)
+ Just (this, bind) -> (this : dfun_dicts, unitBag bind)
+
+ ; inst_loc <- getInstLoc (SigOrigin rigid_info)
+ ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
+
+ ; let full_bind = L loc $
+ AbsBinds tyvars dfun_lam_vars
+ [(tyvars, meth_id, local_meth_id, [])]
+ (this_dict_bind `unionBags` lie_binds
+ `unionBags` tc_bind)
+
+ dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
+
+ ; return (meth_id, unitBag full_bind) }
\end{code}
Note [Polymorphic methods]
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
= do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
- ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (tcPolyExprNC expr)
+ ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty ->
+ tcPolyExprNC expr res_ty
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
-- E.g. forall a. Eq a => forall b. Ord b => ....
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-- Remember to extend the lexical type-variable environment
- ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $
- tcMonoExprNC expr
+ ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ 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_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
import SrcLoc
import Util
import Outputable
-import Maybes
import Bag
import BasicTypes
import HscTypes
{-# INLINE [2] op1_i #-} -- From the instance decl bindings
op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
op1_i = /\a. \(d:C a).
- let local_op1 :: forall a. (C a, C [a])
- => forall b. Ix b => [a] -> b -> b
+ let this :: C [a]
+ this = df_i a d
+
+ local_op1 :: forall b. Ix b => [a] -> b -> b
-- Note [Subtle interaction of recursion and overlap]
local_op1 = <rhs>
-- Source code; run the type checker on this
-- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
-- Note [Tricky type variable scoping]
- in local_op1 a d (df_i a d)
+ in local_op1 a d
op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
does the same thing; it shows up in module Fraction.hs
Conclusion: when typechecking the methods in a C [a] instance, we want
-to have C [a] available. That is why we have the strange local let in
-the definition of op1_i in the example above. We can typecheck the
-defintion of local_op1, and then supply the "this" argument via an
-explicit call to the dfun (which in turn will be inlined).
+to have C [a] available. That is why we have the strange local
+definition for 'this' in the definition of op1_i in the example above.
+We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
+we supply 'this' as a given dictionary. Only needed, though, if there
+are some type variales involved; otherwise there can be no overlap and
+none of this arises.
Note [Tricky type variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
-- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
- ; inst_loc <- getInstLoc origin
; sc_loc <- getInstLoc InstScOrigin
- ; dfun_dicts <- newDictBndrs inst_loc theta
; sc_dicts <- newDictBndrs sc_loc sc_theta'
+ ; inst_loc <- getInstLoc origin
+ ; dfun_dicts <- newDictBndrs inst_loc theta
; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
; rep_dict <- newDictBndr inst_loc rep_pred
-- Figure out bindings for the superclass context from dfun_dicts
-- Don't include this_dict in the 'givens', else
- -- wanted_sc_insts get bound by just selecting from this_dict!!
+ -- sc_dicst get bound by just selecting from this_dict!!
; sc_binds <- addErrCtxt superClassCtxt $
tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
+ -- It's possible that the superclass stuff might unified something
+ -- in the envt with one of the clas_tyvars
+ ; checkSigTyVars class_tyvars
+
; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
-- Instantiate the super-class context with inst_tys
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
- (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta'
origin = SigOrigin rigid_info
- (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
-- Create dictionary Ids from the specified instance contexts.
- sc_loc <- getInstLoc InstScOrigin
- sc_dicts <- newDictBndrs sc_loc dict_sc_theta'
- inst_loc <- getInstLoc origin
- sc_covars <- mkMetaCoVars eq_sc_theta'
- wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
- dfun_covars <- mkCoVars eq_dfun_theta'
- dfun_eqs <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
- dfun_dicts <- newDictBndrs inst_loc dict_dfun_theta'
- this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
+ sc_loc <- getInstLoc InstScOrigin
+ sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted
+ inst_loc <- getInstLoc origin
+ dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities
+ this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
-- Typecheck the methods
- let -- These insts are in scope; quite a few, eh?
- dfun_insts = dfun_eqs ++ dfun_dicts
- wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
- this_dict_id = instToId this_dict
- sc_dict_ids = map instToId sc_dicts
- dfun_dict_ids = map instToId dfun_dicts
- prag_fn = mkPragFun uprags
- tc_meth = tcInstanceMethod loc clas inst_tyvars'
- (dfun_covars ++ dfun_dict_ids)
- dfun_theta' inst_tys'
- this_dict_id dfun_id
- prag_fn monobinds
- (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items
+ let this_dict_id = instToId this_dict
+ dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities
+ prag_fn = mkPragFun uprags
+ tc_meth = tcInstanceMethod loc clas inst_tyvars'
+ dfun_dicts
+ dfun_theta' inst_tys'
+ this_dict dfun_id
+ prag_fn monobinds
+ (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
+ mapAndUnzipM tc_meth op_items
-- Figure out bindings for the superclass context
-- Don't include this_dict in the 'givens', else
- -- wanted_sc_insts get bound by just selecting from this_dict!!
+ -- sc_dicts get bound by just selecting from this_dict!!
sc_binds <- addErrCtxt superClassCtxt $
- tcSimplifySuperClasses inst_loc dfun_insts
- wanted_sc_insts
+ tcSimplifySuperClasses inst_loc dfun_dicts sc_dicts
-- Note [Recursive superclasses]
- -- It's possible that the superclass stuff might unified one
- -- of the inst_tyavars' with something in the envt
+ -- It's possible that the superclass stuff might unified something
+ -- in the envt with one of the inst_tyvars'
checkSigTyVars inst_tyvars'
-- Deal with 'SPECIALISE instance' pragmas
-- Create the result bindings
let
dict_constr = classDataCon clas
- inline_prag | null dfun_insts = []
+ inline_prag | null dfun_dicts = []
| otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
--
-- See Note [Inline dfuns] below
- dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
- (map HsVar sc_dict_ids ++ meth_exprs)
+ sc_dict_vars = map instToVar sc_dicts
+ dict_bind = L loc (VarBind this_dict_id dict_rhs)
+ dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
+ inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
+ (dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
- dict_bind = noLoc (VarBind this_dict_id dict_rhs)
main_bind = noLoc $ AbsBinds
- (inst_tyvars' ++ dfun_covars)
- dfun_dict_ids
- [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
+ inst_tyvars'
+ dfun_lam_vars
+ [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)]
(dict_bind `consBag` sc_binds)
showLIE (text "instance")
return (main_bind `consBag` unionManyBags meth_binds)
-
-mkCoVars :: [PredType] -> TcM [TyVar]
-mkCoVars = newCoVars . map unEqPred
- where
- unEqPred (EqPred ty1 ty2) = (ty1, ty2)
- unEqPred _ = panic "TcInstDcls.mkCoVars"
-
-mkMetaCoVars :: [PredType] -> TcM [TyVar]
-mkMetaCoVars = mapM eqPredToCoVar
- where
- eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
- eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
\end{code}
Note [Recursive superclasses]
- Use tcValBinds to do the checking
\begin{code}
-tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
+tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst]
-> TcThetaType -> [TcType]
- -> Id -> Id
+ -> Inst -> Id
-> TcPragFun -> LHsBinds Name
-> (Id, DefMeth)
-> TcM (HsExpr Id, LHsBinds Id)
-- The returned inst_meth_ids all have types starting
-- forall tvs. theta => ...
-tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys
- this_dict_id dfun_id
- prag_fn binds_in (sel_id, dm_info)
- = do { uniq <- newUnique
- ; let local_meth_name = mkInternalName uniq sel_occ loc -- Same OccName
- tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
- this_dict_id dfun_id sel_id
- prags local_meth_name
+tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys
+ this_dict dfun_id prag_fn binds_in (sel_id, dm_info)
+ = do { cloned_this <- cloneDict this_dict
+ -- Need to clone the dict in case it is floated out, and
+ -- then clashes with its friends
+ ; uniq1 <- newUnique
+ ; let local_meth_name = mkInternalName uniq1 sel_occ loc -- Same OccName
+ this_dict_bind = L loc $ VarBind (instToId cloned_this) $
+ L loc $ wrapId meth_wrapper dfun_id
+ mb_this_bind | null tyvars = Nothing
+ | otherwise = Just (cloned_this, this_dict_bind)
+ -- Only need the this_dict stuff if there are type variables
+ -- involved; otherwise overlap is not possible
+ -- See Note [Subtle interaction of recursion and overlap]
+
+ tc_body rn_bind = do { (meth_id, tc_binds) <- tcInstanceMethodBody
+ InstSkol clas tyvars dfun_dicts theta inst_tys
+ mb_this_bind sel_id
+ local_meth_name
+ meth_sig_fn meth_prag_fn rn_bind
+ ; return (wrapId meth_wrapper meth_id, tc_binds) }
; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
-- There is a user-supplied method binding, so use it
where
sel_name = idName sel_id
sel_occ = nameOccName sel_name
- prags = prag_fn sel_name
-
- error_rhs = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg
- meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
- error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
+ this_dict_id = instToId this_dict
+
+ meth_prag_fn _ = prag_fn sel_name
+ meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig"
+ -- But there are no scoped type variables from local_method_id
+ -- Only the ones from the instance decl itself, which are already
+ -- in scope. Example:
+ -- class C a where { op :: forall b. Eq b => ... }
+ -- instance C [c] where { op = <rhs> }
+ -- In <rhs>, 'c' is scope but 'b' is not!
+
+ error_rhs = HsApp error_fun error_msg
+ error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+ meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys
omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
<+> quotes (ppr sel_id)
----------------
-tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var]
- -> TcThetaType -> [TcType]
- -> Id -> Id -> Id
- -> [LSig Name] -> Name -> LHsBind Name
- -> TcM (HsExpr Id, LHsBinds Id)
-tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
- this_dict_id dfun_id sel_id
- prags local_meth_name bind@(L loc _)
- = do { uniq <- newUnique
- ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
- rho_ty = ASSERT( length sel_tyvars == length inst_tys )
- substTyWith sel_tyvars inst_tys sel_rho
-
- (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
- `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
-
- meth_name = mkInternalName uniq (getOccName local_meth_name) loc
- meth_ty = mkSigmaTy tyvars theta meth_tau
- meth_id = mkLocalId meth_name meth_ty
-
- local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau
- local_meth_id = mkLocalId local_meth_name local_meth_ty
-
- tv_names = map tyVarName tyvars
-
- -- The first predicate should be of form (C a b)
- -- where C is the class in question
- ; MASSERT( case getClassPredTys_maybe first_pred of
- { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
-
- ; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind
-
- ; let full_bind = unitBag $ L loc $
- VarBind meth_id $ L loc $
- mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $
- HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $
- mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $
- wrapId meth_wrapper local_meth_id
- this_dict_bind = unitBag $ L loc $
- VarBind this_dict_id $ L loc $
- wrapId meth_wrapper dfun_id
-
- ; return (wrapId meth_wrapper meth_id, full_bind) }
- where
+ dfun_lam_vars = map instToVar dfun_dicts
meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
+
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
\end{code}
| isSigmaTy res_ty -- Do this before checking n==0, because we
-- guarantee to return a BoxyRhoType, not a
-- BoxySigmaType
- = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $
- loop n args_so_far
+ = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ \ _ res_ty ->
+ loop n args_so_far res_ty
; return (gen_fn <.> co_fn, res) }
loop 0 args_so_far res_ty
if exp_ib then -- SKOL does not apply if exp_ty is inside a box
defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty
else do
- { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ body_exp_ty ->
+ { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ _ body_exp_ty ->
tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty
; return (gen_fn <.> co_fn) }
}
%************************************************************************
\begin{code}
-tcGen :: BoxySigmaType -- expected_ty
- -> TcTyVarSet -- Extra tyvars that the universally
- -- quantified tyvars of expected_ty
- -- must not be unified
- -> Maybe UserTypeCtxt -- Just ctxt => this polytype arose directly from
- -- a user type sig; bring tyvars into scope
- -- Nothing => a higher order situation
- -> (BoxyRhoType -> TcM result)
+tcGen :: BoxySigmaType -- expected_ty
+ -> TcTyVarSet -- Extra tyvars that the universally
+ -- quantified tyvars of expected_ty
+ -- must not be unified
+ -> Maybe UserTypeCtxt -- Just ctxt => this polytype arose directly
+ -- from a user type sig
+ -- Nothing => a higher order situation
+ -> ([TcTyVar] -> BoxyRhoType -> TcM result)
-> TcM (HsWrapper, result)
-- The expression has type: spec_ty -> expected_ty
tcGen expected_ty extra_tvs mb_ctxt thing_inside -- We expect expected_ty to be a forall-type
-- If not, the call is a no-op
= do { traceTc (text "tcGen")
- ; ((tvs', theta', rho'), skol_info, scoped_tvs) <- instantiate expected_ty
+ ; ((tvs', theta', rho'), skol_info) <- instantiate expected_ty
; when debugIsOn $
traceTc (text "tcGen" <+> vcat [
-- Type-check the arg and unify with poly type
; (result, lie) <- getLIE $
- tcExtendTyVarEnv2 (scoped_tvs `zip` mkTyVarTys tvs') $
- -- Extend the lexical type-variable environment
- -- if we're in a user-type context
- thing_inside rho'
+ thing_inside tvs' rho'
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
- instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo, [Name])
+ instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo)
instantiate expected_ty
- | Just ctxt <- mb_ctxt
+ | Just ctxt <- mb_ctxt -- This case split is the wohle reason for mb_ctxt
= do { let skol_info = SigSkol ctxt
- tv_names = map tyVarName (fst (tcSplitForAllTys expected_ty))
; stuff <- tcInstSigType True skol_info expected_ty
- ; return (stuff, skol_info, tv_names) }
+ ; return (stuff, skol_info) }
| otherwise -- We want the GenSkol info in the skolemised type variables to
-- mention the *instantiated* tyvar names, so that we get a
-- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-- Hence the tiresome but innocuous fixM
- = fixM $ \ ~(_, skol_info, _) ->
+ = fixM $ \ ~(_, skol_info) ->
do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
-- Get loation from *monad*, not from expected_ty
; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
- ; return (stuff, skol_info, []) }
+ ; return (stuff, skol_info) }
\end{code}
projects / ghc-hetmet.git / commitdiff