X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=71e8659b15d906080ab8f97897dfd9fc947f42c5;hp=575c20b70bac4367a6614ecb4089e61a7245fce7;hb=9a4ef343a46e823bcf949af8501c13cc8ca98fb1;hpb=cc9a63c2552d74abc1fefae647aeba062ea76b71 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 575c20b..71e8659 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -275,7 +275,8 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; checkTc (isSynTyCon family) (wrongKindOfFamily family) ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better -- we need the exact same number of type parameters as the family -- declaration @@ -378,7 +379,8 @@ kcIdxTyPats :: TyClDecl Name -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl) + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) ; hs_typats = fromJust $ tcdTyPats decl } @@ -388,10 +390,11 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckLHsType hs_typats kinds + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] ; thing_inside tvs typats resultKind fam_tycon } - where \end{code} @@ -1095,7 +1098,8 @@ checkValidDataCon :: TyCon -> DataCon -> TcM () checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { let tc_tvs = tyConTyVars tc + do { traceTc (ptext (sLit "Validity of data con") <+> ppr con) + ; let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) actual_res_ty = dataConOrigResTy con ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) @@ -1204,6 +1208,9 @@ checkValidClass cls \begin{code} mkAuxBinds :: [TyThing] -> HsValBinds Name +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications mkAuxBinds ty_things = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where @@ -1212,47 +1219,44 @@ mkAuxBinds ty_things | ATyCon tc <- ty_things , fld <- tyConFields tc ] - mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, sel_name) = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) where - loc = getSrcSpan tycon - sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo + loc = getSrcSpan tycon + sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } -- Find a representative constructor, con1 - all_cons = tyConDataCons tycon + all_cons = tyConDataCons tycon cons_w_field = [ con | con <- all_cons , sel_name `elem` dataConFieldLabels con ] con1 = ASSERT( not (null cons_w_field) ) head cons_w_field -- Selector type; Note [Polymorphic selectors] - field_ty = dataConFieldType con1 sel_name - (field_tvs, field_theta, field_tau) - | is_naughty = ([], [], unitTy) - | otherwise = tcSplitSigmaTy field_ty + field_ty = dataConFieldType con1 sel_name data_ty = dataConOrigResTy con1 data_tvs = tyVarsOfType data_ty is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) - sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ - mkPhiTy (dataConStupidTheta con1) $ -- Urgh! - mkPhiTy field_theta $ -- Urgh! - mkFunTy data_ty field_tau + (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty + sel_ty | is_naughty = unitTy + | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau -- Make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) + sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs] + | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] - (L loc match_body) + (L loc (HsVar field_var)) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = HsRecField { hsRecFieldId = sel_lname , hsRecFieldArg = nlVarPat field_var , hsRecPun = False } - match_body | is_naughty = ExplicitTuple [] Boxed - | otherwise = HsVar field_var sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -1263,6 +1267,8 @@ mkRecSelBind (tycon, sel_name) | otherwise = [mkSimpleMatch [nlWildPat] (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) (nlHsLit msg_lit))] + + unit_rhs = L loc $ ExplicitTuple [] Boxed msg_lit = HsStringPrim $ mkFastString $ occNameString (getOccName sel_name) @@ -1299,8 +1305,11 @@ Hence the sel_naughty flag, to identify record selectors that don't really exist In general, a field is naughty if its type mentions a type variable that isn't in the result type of the constructor. -We make a dummy binding for naughty selectors, so that they can be treated -uniformly, apart from their sel_naughty field. The function is never called. +We make a dummy binding + sel = () +for naughty selectors, so that the later type-check will add them to the +environment, and they'll be exported. The function is never called, because +the tyepchecker spots the sel_naughty field. Note [GADT record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~