diff options
Diffstat (limited to 'compiler/typecheck/TcTyClsDecls.hs')
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 45 |
1 files changed, 26 insertions, 19 deletions
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 8e42ff261f..a2b6a6386e 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -32,6 +32,7 @@ import TcTyDecls import TcClassDcl import TcHsType import TcMType +import RnTypes( collectAnonWildCards ) import TcType import FamInst import FamInstEnv @@ -171,10 +172,11 @@ tcTyClGroup tyclds zipRecTyClss :: [(Name, Kind)] -> [TyCon] -- Knot-tied -> [(Name,TyThing)] --- Build a name-TyThing mapping for the things bound by decls --- being careful not to look at the [TyThing] +-- Build a name-TyThing mapping for the TyCons bound by decls +-- being careful not to look at the knot-tied [TyThing] -- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor +-- because typechecking types (in, say, tcTyClDecl) looks at +-- this outer constructor zipRecTyClss kind_pairs rec_tycons = [ (name, ATyCon (get name)) | (name, _kind) <- kind_pairs ] where @@ -478,9 +480,8 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty) - kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) - kc_sig _ = return () + kc_sig (ClassOpSig _ nms op_ty) = kcClassSigType nms op_ty + kc_sig _ = return () -- closed type families look at their equations, but other families don't -- do anything here @@ -1046,9 +1047,9 @@ famTyConShape fam_tc tc_fam_ty_pats :: FamTyConShape -> Maybe ClsInfo - -> HsWithBndrs Name [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored + -> HsTyPats Name -- Patterns + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored -> TcM ([Kind], [Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -1062,8 +1063,8 @@ tc_fam_ty_pats :: FamTyConShape -- (and, if C is poly-kinded, so will its kind parameter). tc_fam_ty_pats (name, arity, kind) mb_clsinfo - (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars - , hswb_tvs = tvars, hswb_wcs = wcs }) + (HsIB { hsib_body = arg_pats, hsib_kvs = kvars + , hsib_tvs = tvars }) kind_checker = do { let (fam_kvs, fam_body) = splitForAllTys kind @@ -1089,14 +1090,16 @@ tc_fam_ty_pats (name, arity, kind) mb_clsinfo substKiWith fam_kvs fam_arg_kinds fam_body -- Treat (anonymous) wild cards as type variables without a name. -- See Note [Wild cards in family instances] - anon_tvs = [L (nameSrcSpan wc) - (UserTyVar (L (nameSrcSpan wc) wc)) | wc <- wcs] + wcs = concatMap collectAnonWildCards arg_pats + anon_tvs = [L loc (UserTyVar (L loc wc)) + | wc <- wcs + , let loc = nameSrcSpan wc ] hs_tvs = HsQTvs { hsq_kvs = kvars , hsq_tvs = anon_tvs ++ userHsTyVarBndrs loc tvars } -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> + ; typats <- tcHsQTyVars hs_tvs $ \ _ -> do { kind_checker res_kind ; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds } @@ -1105,8 +1108,8 @@ tc_fam_ty_pats (name, arity, kind) mb_clsinfo -- See Note [tc_fam_ty_pats vs tcFamTyPats] tcFamTyPats :: FamTyConShape -> Maybe ClsInfo - -> HsWithBndrs Name [LHsType Name] -- patterns - -> (TcKind -> TcM ()) -- kind-checker for RHS + -> HsTyPats Name -- patterns + -> (TcKind -> TcM ()) -- kind-checker for RHS -> ([TKVar] -- Kind and type variables -> [TcType] -- Kind and type arguments -> Kind -> TcM a) @@ -1264,9 +1267,10 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) ; (ctxt, arg_tys, res_ty, field_lbls, stricts) - <- tcHsTyVarBndrs hs_tvs $ \ _ -> - do { ctxt <- tcHsContext hs_ctxt - ; btys <- tcConArgs new_or_data hs_details + <- tcHsQTyVars hs_tvs $ \ _ -> + do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs) + ; ctxt <- tcHsContext hs_ctxt + ; btys <- tcConArgs new_or_data hs_details ; res_ty <- tcConRes hs_res_ty ; field_lbls <- lookupConstructorFields (unLoc $ head names) ; let (arg_tys, stricts) = unzip btys @@ -1299,6 +1303,9 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl -- See Note [Checking GADT return types] ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfix name hs_details res_ty |