TcHsBinds(..), TcIdOcc(..)
)
import Inst ( newDicts, InstOrigin(..), Inst )
-import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
+import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
import TcType ( tcInstTyVars, tcInstType, tcInstId )
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
newLocalId, newLocalIds
\d1::Data a, d2::C b ->
\p q r -> case p of { p ->
case q of { q ->
- HsCon [a,b,c] [p,q,r]}}
+ HsCon T1 [a,b] [p,q,r]}}
Notice that
(arg_tys, result_ty) = splitFunTy tau
n_args = length arg_tys
in
- newLocalIds (take n_args (repeat SLIT("con"))) arg_tys `thenNF_Tc` {- \ pre_zonk_args ->
- mapNF_Tc zonkId pre_zonk_args `thenNF_Tc` -} \ args ->
+ newLocalIds (take n_args (repeat SLIT("con"))) arg_tys
+ `thenNF_Tc` \ args ->
- -- Check that all the types of all the strict
- -- arguments are in Data. This is trivially true of everything except
- -- type variables, for which we must check the context.
+ -- Check that all the types of all the strict arguments are in Data.
+ -- This is trivially true of everything except type variables, for
+ -- which we must check the context.
let
strict_marks = dataConStrictMarks con_id
strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks]
data_tyvars = -- The tyvars in the constructor's context that are arguments
-- to the Data class
[getTyVar "mkConstructor" ty
- | (clas,ty) <- theta,
- uniqueOf clas == evalClassKey]
+ | (clas,ty) <- theta, uniqueOf clas == evalClassKey]
check_data arg = case getTyVar_maybe (tcIdType arg) of
Nothing -> returnTc () -- Not a tyvar, so OK
Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar)
in
- mapTc check_data strict_args `thenTc_`
+ mapTc check_data strict_args `thenTc_`
-- Build the data constructor
let
mkHsDictLam dicts $
mk_pat_match args $
mk_case strict_args $
- HsCon con_id arg_tys (map HsVar args)
+ HsCon con_id (mkTyVarTys tyvars) (map HsVar args)
mk_pat_match [] body = body
mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body)))
returnTc data_con
tcField (field_label_names, bty)
- = tcMonoType (get_ty bty) `thenTc` \ field_ty ->
+ = tcPolyType (get_pty bty) `thenTc` \ field_ty ->
returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
tcDataCon tycon tyvars ctxt name btys src_loc
= tcAddSrcLoc src_loc $
let
stricts = map get_strictness btys
- tys = map get_ty btys
+ tys = map get_pty btys
in
- mapTc tcMonoType tys `thenTc` \ arg_tys ->
+ mapTc tcPolyType tys `thenTc` \ arg_tys ->
let
data_con = mkDataCon (getName name)
stricts
arg_tyvars = tyVarsOfTypes arg_tys
in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
-get_strictness (Banged ty) = MarkedStrict
-get_strictness (Unbanged ty) = NotMarkedStrict
+get_strictness (Banged _) = MarkedStrict
+get_strictness (Unbanged _) = NotMarkedStrict
-get_ty (Banged ty) = ty
-get_ty (Unbanged ty) = ty
+get_pty (Banged ty) = ty
+get_pty (Unbanged ty) = ty
\end{code}