X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=633dc52812add6baabc4ba4b2c9b0df470e68fca;hp=eccd498b3260aba0551ed99d9d10ef2e1835398d;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=21eea25f1212ec306aac806233a2ec048212d529 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index eccd498..633dc52 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} @@ -587,7 +590,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here - kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) + kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) = addErrCtxt (dataConCtxt name) $ kcHsTyVars ex_tvs $ \ex_tvs' -> do do { ex_ctxt' <- kcHsContext ex_ctxt @@ -595,7 +599,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; res' <- case res of ResTyH98 -> return ResTyH98 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) } + ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' + , con_details = details', con_res = res' }) } kc_con_details (PrefixCon btys) = do { btys' <- mapM kc_larg_ty btys @@ -826,7 +831,8 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> TcM DataCon tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types - (ConDecl name _ tvs ctxt details res_ty _) + (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt + , con_details = details, con_res = res_ty }) = addErrCtxt (dataConCtxt name) $ tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -1205,6 +1211,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 @@ -1213,47 +1222,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 -- See Note [Naughty record selectors] + | 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 @@ -1264,6 +1270,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) @@ -1297,11 +1305,16 @@ so that if the user tries to use 'x' as a selector we can bleat helpfully, rather than saying unhelpfully that 'x' is not in scope. 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. +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a -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. +For naughty selectors 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~