- = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
- newDicts orig theta `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
- let
- inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts)
- in
- returnM (mkCoercion inst_fn, tau)
-
-tcInstDataCon :: InstOrigin
- -> TyVarDetails -- Use this for the existential tyvars
- -- ExistTv when pattern-matching,
- -- VanillaTv at a call of the constructor
- -> DataCon
- -> TcM ([TcType], -- Types to instantiate at
- [Inst], -- Existential dictionaries to apply to
- [TcType], -- Argument types of constructor
- TcType, -- Result type
- [TyVar]) -- Existential tyvars
-tcInstDataCon orig ex_tv_details data_con
- = let
- (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
- -- We generate constraints for the stupid theta even when
- -- pattern matching (as the Report requires)
- in
- mappM (tcInstTyVar VanillaTv) tvs `thenM` \ tvs' ->
- mappM (tcInstTyVar ex_tv_details) ex_tvs `thenM` \ ex_tvs' ->
- let
- tv_tys' = mkTyVarTys tvs'
- ex_tv_tys' = mkTyVarTys ex_tvs'
- all_tys' = tv_tys' ++ ex_tv_tys'
-
- tenv = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys'
- stupid_theta' = substTheta tenv stupid_theta
- ex_theta' = substTheta tenv ex_theta
- arg_tys' = map (substTy tenv) arg_tys
- result_ty' = mkTyConApp tycon tv_tys'
- in
- newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
- newDicts orig ex_theta' `thenM` \ ex_dicts ->
-
- -- Note that we return the stupid theta *only* in the LIE;
- -- we don't otherwise use it at all
- extendLIEs stupid_dicts `thenM_`
-
- returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs')
+ = do { (tyvars, theta, tau) <- tcInstType fun_ty
+ ; dicts <- newDicts orig theta
+ ; extendLIEs dicts
+ ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars))
+ (map instToId dicts))
+ ; return (mkCoercion inst_fn, tyvars, tau) }
+
+tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
+-- Instantiate the "stupid theta" of the data con, and throw
+-- the constraints into the constraint set
+tcInstStupidTheta data_con inst_tys
+ | null stupid_theta
+ = return ()
+ | otherwise
+ = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
+ (substTheta tenv stupid_theta)
+ ; extendLIEs stupid_dicts }
+ where
+ stupid_theta = dataConStupidTheta data_con
+ tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys