From: Simon Peyton Jones Date: Thu, 26 May 2011 13:30:15 +0000 (+0100) Subject: Rejig the way in which generic default method signatures are checked X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8f212ab5307434edf92c7d10fe0df88ccb5cd6ca Rejig the way in which generic default method signatures are checked - Check GenericSig in tcClassSigs, along with TypeSig - Add the generic default methods to the type envt - Look them up via tcLookupId in TcClassDcl.tcDefMeth Much nicer! --- diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index a3f441e..eabe8c4 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -222,8 +222,8 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ \begin{code} type TcMethInfo = (Name, DefMethSpec, Type) - -- A temporary intermediate, to communicate between tcClassSigs and - -- buildClass. + -- A temporary intermediate, to communicate between + -- tcClassSigs and buildClass. buildClass :: Bool -- True <=> do not include unfoldings -- on dict selectors diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 493466b..22aa3f4 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1036,7 +1036,9 @@ implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) implicitClassThings :: Class -> [TyThing] implicitClassThings cl - = -- dictionary datatype: + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + -- Dictionary datatype: -- [extras_plus:] -- type constructor -- [recursive call:] diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index fe7cb81..8fc8a24 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -27,6 +27,8 @@ import BuildTyCl( TcMethInfo ) import Class import Id import Name +import NameEnv +import NameSet import Var import Outputable import DynFlags @@ -81,39 +83,43 @@ Death to "ExpandingDicts". %************************************************************************ \begin{code} -tcClassSigs :: Name -- Name of the class +tcClassSigs :: Name -- Name of the class -> [LSig Name] -> LHsBinds Name - -> TcM [TcMethInfo] -- One for each method - + -> TcM ([TcMethInfo], -- Exactly one for each method + NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods - = do { -- Check that all def_methods are in the class - ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs] - ; let op_names = [ n | (n,_,_) <- op_info ] + = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] ; sequence_ [ failWithTc (badMethodErr clas n) - | n <- dm_bind_names, not (n `elem` op_names) ] + | n <- dm_bind_names, not (n `elemNameSet` op_names) ] -- Value binding for non class-method (ie no TypeSig) ; sequence_ [ failWithTc (badGenericMethod clas n) - | n <- genop_names, not (n `elem` dm_bind_names) ] + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] -- Generic signature without value binding - ; return op_info } + ; return (op_info, gen_dm_env) } where + vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - genop_names :: [Name] -- These ones have a generic signature - genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs] - - tc_sig (TypeSig (L _ op_name) op_hs_ty) + tc_sig genop_env (L _ op_name, op_hs_ty) = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope - ; let dm | op_name `elem` genop_names = GenericDM - | op_name `elem` dm_bind_names = VanillaDM - | otherwise = NoDM + ; let dm | op_name `elemNameEnv` genop_env = GenericDM + | op_name `elem` dm_bind_names = VanillaDM + | otherwise = NoDM ; return (op_name, dm, op_ty) } - tc_sig sig = pprPanic "tc_cls_sig" (ppr sig) + + tc_gen_sig (L _ op_name, gen_hs_ty) + = do { gen_op_ty <- tcHsKindedType gen_hs_ty + ; return (op_name, gen_op_ty) } \end{code} @@ -151,7 +157,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; traceTc "TIM2" (ppr sigs) ; let tc_dm = tcDefMeth clas clas_tyvars - this_dict default_binds sigs + this_dict default_binds sig_fn prag_fn ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ @@ -161,7 +167,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) -tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name] +tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> SigFun -> PragFun -> ClassOpItem -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) @@ -170,15 +176,12 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name] -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) -tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info) +tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) = case dm_info of NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags ; return emptyBag } - DefMeth dm_name -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars)) - GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name) - ; tc_dm dm_name tau } - -- In the case of a generic default, we have to get the type from the signature - -- Otherwise we can get it by instantiating the method selector + DefMeth dm_name -> tc_dm dm_name + GenDefMeth dm_name -> tc_dm dm_name where sel_name = idName sel_id prags = prag_fn sel_name @@ -193,13 +196,13 @@ tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info) -- The "local_dm_ty" is precisely the type in the above -- type signatures, ie with no "forall a. C a =>" prefix - tc_dm dm_name local_dm_ty - = do { local_dm_name <- newLocalName sel_name + tc_dm dm_name + = do { dm_id <- tcLookupId dm_name + ; local_dm_name <- newLocalName sel_name -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty - dm_id = mkExportedLocalId dm_name dm_ty + ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) local_dm_id = mkLocalId local_dm_name local_dm_ty ; dm_id_w_inline <- addInlinePrags dm_id prags @@ -215,23 +218,6 @@ tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info) ; return (unitBag tc_bind) } - tc_genop_ty :: LHsType Name -> TcM Type - tc_genop_ty hs_ty - = setSrcSpan (getLoc hs_ty) $ - do { tau <- tcHsKindedType hs_ty - ; checkValidType (FunSigCtxt sel_name) tau - ; return tau } - -findGenericSig :: [LSig Name] -> Name -> LHsType Name --- Find the 'generic op :: ty' signature among the sigs --- If dm_info is GenDefMeth, the corresponding signature --- should jolly well exist! Hence the panic -findGenericSig sigs sel_name - = case [lty | L _ (GenericSig (L _ n) lty) <- sigs - , n == sel_name ] of - [lty] -> lty - _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs) - --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] -> Id -> Id diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 2542ad3..5aa6959 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -245,7 +245,6 @@ tcRnImports hsc_env this_mod import_decls -- interfaces, so that their rules and instance decls will be -- found. ; loadOrphanModules (imp_orphs imports) False - ; loadOrphanModules (imp_finsts imports) True -- Check type-familily consistency ; traceRn (text "rn1: checking family instance consistency") @@ -299,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -500,10 +499,9 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc "Tc2" empty - ; (tcg_env, aux_binds, dm_ids, _) + ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ - tcExtendIdEnv dm_ids $ do { + ; setGblEnv tcg_env $ do { -- Typecheck instance decls -- Family instance declarations are rejected here @@ -837,11 +835,10 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc "Tc2" empty ; - (tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - setGblEnv tcg_env $ - tcExtendIdEnv dm_ids $ do { + setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations @@ -877,7 +874,7 @@ tcTopSrcDecls boot_details -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 kc_decls inst_infos ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1387,7 +1384,6 @@ tcGetModuleExports mod directlyImpMods -- Load any orphan-module and family instance-module -- interfaces, so their instances are visible. ; loadOrphanModules (dep_orphs (mi_deps iface)) False - ; loadOrphanModules (dep_finsts (mi_deps iface)) True -- Check that the family instances of all directly loaded -- modules are consistent. diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index d4e859b..8d62b78 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -35,6 +35,7 @@ import IdInfo import Var import VarSet import Name +import NameEnv import Outputable import Maybes import Unify @@ -65,9 +66,7 @@ tcTyAndClassDecls :: ModDetails -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons - HsValBinds Name, -- Renamed bindings for record selectors - [Id], -- Default method ids - [LTyClDecl Name]) -- Kind-checked declarations + HsValBinds Name) -- Renamed bindings for record selectors -- Fails if there are any errors tcTyAndClassDecls boot_details decls_s @@ -109,11 +108,10 @@ tcTyAndClassDecls boot_details decls_s ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] ; dm_ids = mkDefaultMethodIds tyclss } - ; env <- tcExtendGlobalEnv implicit_things getGblEnv - -- We need the kind-checked declarations later, so we return them - -- from here - ; kc_decls <- kcTyClDecls tyclds_s - ; return (env, rec_sel_binds, dm_ids, kc_decls) } } + ; env <- tcExtendGlobalEnv implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv + ; return (env, rec_sel_binds) } } zipRecTyClss :: [[LTyClDecl Name]] -> [TyThing] -- Knot-tied @@ -524,7 +522,7 @@ tcTyClDecl1 _parent calc_isrec tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we @@ -537,7 +535,18 @@ tcTyClDecl1 _parent calc_isrec ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' (concat atss') sig_stuff tc_isrec } - ; return (AClass clas : map ATyCon (classATs clas)) + + ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) + | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas + , let gen_dm_tau = expectJust "tcTyClDecl1" $ + lookupNameEnv gen_dm_env (idName sel_id) + , let gen_dm_ty = mkSigmaTy tvs' + [mkClassPred clas (mkTyVarTys tvs')] + gen_dm_tau + ] + class_ats = map ATyCon (classATs clas) + + ; return (AClass clas : gen_dm_ids ++ class_ats ) -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } @@ -802,6 +811,8 @@ checkValidTyCl decl ATyCon tc -> checkValidTyCon tc AClass cl -> do { checkValidClass cl ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + AnId _ -> return () -- Generic default methods are checked + -- with their parent class _ -> panic "checkValidTyCl" ; traceTc "Done validity of" (ppr thing) } @@ -964,7 +975,7 @@ checkValidClass cls unary = isSingleton tyvars no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] - check_op constrained_class_methods (sel_id, _) + check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do { checkValidTheta SigmaCtxt (tail theta) -- The 'tail' removes the initial (C a) from the @@ -982,6 +993,11 @@ checkValidClass cls ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) + + ; case dm of + GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name + ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + _ -> return () } where op_name = idName sel_id diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index cb61726..15c817a 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -30,7 +30,7 @@ import NameSet import Digraph import BasicTypes import SrcLoc -import Outputable +import Maybes( mapCatMaybes ) import Util ( isSingleton ) import Data.List \end{code} @@ -253,11 +253,10 @@ calcRecFlags boot_details tyclss nt_loop_breakers `unionNameSets` prod_loop_breakers - all_tycons = [ tc | tycls <- tyclss, + all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss -- Recursion of newtypes/data types can happen via -- the class TyCon, so tyclss includes the class tycons - let tc = getTyCon tycls, - not (tyConName tc `elemNameSet` boot_name_set) ] + , not (tyConName tc `elemNameSet` boot_name_set) ] -- Remove the boot_name_set because they are going -- to be loop breakers regardless. @@ -321,10 +320,10 @@ calcRecFlags boot_details tyclss new_tc_rhs :: TyCon -> Type new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables -getTyCon :: TyThing -> TyCon -getTyCon (ATyCon tc) = tc -getTyCon (AClass cl) = classTyCon cl -getTyCon _ = panic "getTyCon" +getTyCon :: TyThing -> Maybe TyCon +getTyCon (ATyCon tc) = Just tc +getTyCon (AClass cl) = Just (classTyCon cl) +getTyCon _ = Nothing findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] -- Finds a set of tycons that cut all loops