- = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
- newDicts orig theta `thenM` \ dicts ->
- extendLIEs dicts `thenM_`
- let
- inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
- in
- returnM (mkCoercion inst_fn, tau)
-
-tcInstDataCon :: InstOrigin -> 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 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
- tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
- let
- stupid_theta' = substTheta tenv stupid_theta
- ex_theta' = substTheta tenv ex_theta
- arg_tys' = map (substTy tenv) arg_tys
-
- n_normal_tvs = length tvs
- ex_tvs' = drop n_normal_tvs all_tvs'
- result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
- 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 (ty_args', 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