From: Simon Peyton Jones Date: Tue, 19 Apr 2011 10:56:28 +0000 (+0100) Subject: More small fixes to generics branch (doesn't compile yet) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9dcc8bb7a8d4a239c28975c819a9e1267663a530 More small fixes to generics branch (doesn't compile yet) --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 5aebd37..a251734 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -13,7 +13,7 @@ have a standard form, namely: \begin{code} module MkId ( - mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId, + mkDictFunId, mkDictFunTy, mkDictSelId, mkDataConIds, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, @@ -826,11 +826,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId :: Id -- Selector Id - -> Name -- Default method name - -> Id -- Default method Id -mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id) - mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] -> ThetaType diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index a5ce2ea..2e93e90 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -180,55 +180,68 @@ 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 _ tyvars _ binds_in sigs sig_fn prag_fn (sel_id, dm_info) - | NoDefMeth <- dm_info = return emptyBag - | otherwise - = do { (dm_id, tvs, sig_loc) <- tc_dm_id dm_info - ; let L loc meth_bind = findMethodBind sel_name binds_in - `orElse` pprPanic "tcDefMeth" (ppr sel_id) - dm_bind = L loc (meth_bind { fun_id = L loc (idName dm_id) }) - -- Substitute the meth_name for the binder - -- NB: the binding is always a FunBind - - dm_sig_fn _ = Just (clas_tv_names ++ tvs, sig_loc) - dm_prag_fn _ = prag_fn sel_name - - ; (binds,_) <- tcExtendIdEnv [dm_id] $ - tcPolyBinds TopLevel dm_sig_fn dm_prag_fn - NonRecursive NonRecursive - [dm_bind] - ; return binds } +tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info) + = case dm_info of + NoDefMeth -> 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 where - sel_name = idName sel_id - clas_tv_names = map getName tyvars - - -- Find the 'generic op :: ty' signature among the sigs - -- If dm_info is GenDefMeth, the corresponding signature - -- should jolly well exist! Hence the panic - genop_lhs_ty = case [lty | L _ (GenericSig (L _ n) lty) <- sigs - , n == sel_name ] of - [lty] -> lty - _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs) - - tc_dm_id :: DefMeth -> TcM (Id, [Name], SrcSpan) - -- Make a default-method Id of the appropriate type - -- That may entail getting the generic-default signature - -- from the type signatures. - -- Also return the in-scope tyvars for the default method, and their binding site - tc_dm_id NoDefMeth = panic "tc_dm_id" - tc_dm_id (DefMeth dm_name) - | Just (tvs, loc) <- sig_fn sel_name - = return (mkDefaultMethodId sel_id dm_name, tvs, loc) - | otherwise - = pprPanic "No sig for" (ppr sel_name) - tc_dm_id (GenDefMeth dm_name) - = setSrcSpan loc $ - do { tau <- tcHsKindedType genop_lhs_ty - ; checkValidType (FunSigCtxt sel_name) tau - ; return ( mkExportedLocalId dm_name (mkForAllTys tyvars tau) - , hsExplicitTvs genop_lhs_ty, loc ) } - where - loc = getLoc genop_lhs_ty + sel_name = idName sel_id + + -- Eg. class C a where + -- op :: forall b. Eq b => a -> [b] -> a + -- gen_op :: a -> a + -- generic gen_op :: D a => a -> a + -- 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 + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; let meth_bind = findMethodBind sel_name binds_in + `orElse` pprPanic "tcDefMeth" (ppr sel_id) + + dm_sig_fn _ = sig_fn sel_name + dm_prag_fn _ = prag_fn sel_name + + dm_ty = mkSigmaTy tyvars [mkClassPred clas tyvars] local_dm_ty + dm_id = mkExportedLocalId dm_name dm_ty + local_dm_id = mkLocalId local_dm_name local_dm_type + + ; dm_id_w_inline <- addInlinePrags dm_id prags + ; spec_prags <- tcSpecPrags dm_id prags + + ; warnTc (not (null spec_prags)) + (ptext (sLit "Ignoring SPECIALISE pragmas on default method") + <+> quotes (ppr sel_name)) + + ; dm_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] + dm_id_w_inline local_dm_id dm_sig_fn + IsDefaultMethodId dm_bind + + ; return (unitBag dm_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 -> LSig 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] diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index cb07c69..c50dc99 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -30,7 +30,6 @@ import Class import TyCon import DataCon import Id -import MkId ( mkDefaultMethodId ) import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo import Var @@ -1195,7 +1194,7 @@ checkValidClass cls mkDefaultMethodIds :: [TyThing] -> [Id] -- See Note [Default method Ids and Template Haskell] mkDefaultMethodIds things - = [ mkDefaultMethodId sel_id dm_name + = [ mkExportedLocalId dm_name (idType sel_id) | AClass cls <- things , (sel_id, DefMeth dm_name) <- classOpItems cls ] \end{code}