{- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Typechecking class declarations -} {-# LANGUAGE CPP #-} module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcClassMinimalDef, HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs, tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr ) where #include "HsVersions.h" import HsSyn import TcEnv import TcPat( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv ) import TcEvidence( idHsWrapper ) import TcBinds import TcUnify import TcHsType import TcMType import Type ( getClassPredTys_maybe ) import TcType import TcRnMonad import BuildTyCl( TcMethInfo ) import Class import Id import Name import NameEnv import NameSet import Var import Outputable import SrcLoc import Maybes import BasicTypes import Bag import FastString import BooleanFormula import Util import Control.Monad {- Dictionary handling ~~~~~~~~~~~~~~~~~~~ Every class implicitly declares a new data type, corresponding to dictionaries of that class. So, for example: class (D a) => C a where op1 :: a -> a op2 :: forall b. Ord b => a -> b -> b would implicitly declare data CDict a = CDict (D a) (a -> a) (forall b. Ord b => a -> b -> b) (We could use a record decl, but that means changing more of the existing apparatus. One step at at time!) For classes with just one superclass+method, we use a newtype decl instead: class C a where op :: forallb. a -> b -> b generates newtype CDict a = CDict (forall b. a -> b -> b) Now DictTy in Type is just a form of type synomym: DictTy c t = TyConTy CDict `AppTy` t Death to "ExpandingDicts". ************************************************************************ * * Type-checking the class op signatures * * ************************************************************************ -} tcClassSigs :: Name -- Name of the class -> [LSig Name] -> LHsBinds Name -> TcM ([TcMethInfo], -- Exactly one for each method NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods = do { traceTc "tcClassSigs 1" (ppr clas) ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs ; let gen_dm_env = mkNameEnv gen_dm_prs ; op_info <- concat <$> 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 `elemNameSet` op_names) ] -- Value binding for non class-method (ie no TypeSig) ; sequence_ [ failWithTc (badGenericMethod clas n) | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] -- Generic signature without value binding ; traceTc "tcClassSigs 2" (ppr clas) ; 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] tc_sig genop_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope ; traceTc "ClsSig 2" (ppr op_names) ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } where f nm | nm `elemNameEnv` genop_env = GenericDM | nm `elem` dm_bind_names = VanillaDM | otherwise = NoDM tc_gen_sig (op_names, gen_hs_ty) = do { gen_op_ty <- tcClassSigType gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } {- ************************************************************************ * * Class Declarations * * ************************************************************************ -} tcClassDecl2 :: LTyClDecl Name -- The class declaration -> TcM (LHsBinds Id) tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) = recoverM (return emptyLHsBinds) $ setSrcSpan loc $ do { clas <- tcLookupLocatedClass class_name -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... } -- But that desugars into -- ds = \d -> (..., ..., ...) -- dm1 = \d -> case ds d of (a,b,c) -> a -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each ; let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragEnv sigs default_binds sig_fn = mkHsSigFun sigs clas_tyvars = snd (tcSuperSkolTyVars tyvars) pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred ; let tc_item (sel_id, dm_info) = case dm_info of DefMeth dm_name -> tc_dm sel_id dm_name False GenDefMeth dm_name -> tc_dm sel_id dm_name True -- For GenDefMeth, warn if the user specifies a signature -- with redundant constraints; but not for DefMeth, where -- the default method may well be 'error' or something NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } tc_dm = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_item op_items ; return (unionManyBags dm_binds) } tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> HsSigFun -> TcPragEnv -> Id -> Name -> Bool -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) -- This is incompatible with Hugs, which expects a polymorphic -- 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 hs_sig_fn prag_fn sel_id dm_name warn_redundant | Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in -- First look up the default method -- it should be there! = do { global_dm_id <- tcLookupId dm_name ; global_dm_id <- addInlinePrags global_dm_id prags ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name) -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here ; spec_prags <- tcSpecPrags global_dm_id prags ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") <+> quotes (ppr sel_name)) ; let hs_ty = lookupHsSig hs_sig_fn sel_name `orElse` pprPanic "tc_dm" (ppr sel_name) -- We need the HsType so that we can bring the right -- type variables into scope -- -- 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 local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name ; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant } ; (ev_binds, (tc_bind, _)) <- checkConstraints (ClsSkol clas) tyvars [this_dict] $ tcPolyCheck NonRecursive no_prag_fn local_dm_sig' (L bind_loc lm_bind) ; let export = ABE { abe_poly = global_dm_id -- We have created a complete type signature in -- instTcTySig, hence it is safe to call -- completeSigPolyId , abe_mono = completeSigPolyId local_dm_sig' , abe_wrap = idHsWrapper , abe_prags = IsDefaultMethod } full_bind = AbsBinds { abs_tvs = tyvars , abs_ev_vars = [this_dict] , abs_exports = [export] , abs_ev_binds = [ev_binds] , abs_binds = tc_bind } ; return (unitBag (L bind_loc full_bind)) } | otherwise = pprPanic "tcDefMeth" (ppr sel_id) where sel_name = idName sel_id prags = lookupPragEnv prag_fn sel_name no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; -- they are all for meth_id --------------- tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef tcClassMinimalDef _clas sigs op_info = case findMinimalDef sigs of Nothing -> return defMindef Just mindef -> do -- Warn if the given mindef does not imply the default one -- That is, the given mindef should at least ensure that the -- class ops without default methods are required, since we -- have no way to fill them in otherwise whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ (\bf -> addWarnTc (warningMinimalDefIncomplete bf)) return mindef where -- By default require all methods without a default -- implementation whose names don't start with '_' defMindef :: ClassMinimalDef defMindef = mkAnd [ mkVar name | (name, NoDM, _) <- op_info , not (startsWithUnderscore (getOccName name)) ] instantiateMethod :: Class -> Id -> [TcType] -> TcType -- Take a class operation, say -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a -- Instantiate it at [ty1,ty2] -- Return the "local method type": -- forall c. Ix x => (ty2,c) -> ty1 instantiateMethod clas sel_id inst_tys = ASSERT( ok_first_pred ) local_meth_ty where (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) rho_ty = ASSERT( length sel_tyvars == length inst_tys ) substTyWith sel_tyvars inst_tys sel_rho (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) ok_first_pred = case getClassPredTys_maybe first_pred of Just (clas1, _tys) -> clas == clas1 Nothing -> False -- The first predicate should be of form (C a b) -- where C is the class in question --------------------------- type HsSigFun = NameEnv (LHsType Name) emptyHsSigs :: HsSigFun emptyHsSigs = emptyNameEnv mkHsSigFun :: [LSig Name] -> HsSigFun mkHsSigFun sigs = mkNameEnv [(n, hs_ty) | L _ (TypeSig ns hs_ty _) <- sigs , L _ n <- ns ] lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) lookupHsSig = lookupNameEnv --------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings -> Maybe (LHsBind Name, SrcSpan) -- Returns the binding, and the binding -- site of the method binder findMethodBind sel_name binds = foldlBag mplus Nothing (mapBag f binds) where f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) | op_name == sel_name = Just (bind, bndr_loc) f _other = Nothing --------------------------- findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig Name -> Maybe ClassMinimalDef toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf) toMinimalDef _ = Nothing {- Note [Polymorphic methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider class Foo a where op :: forall b. Ord b => a -> b -> b -> b instance Foo c => Foo [c] where op = e When typechecking the binding 'op = e', we'll have a meth_id for op whose type is op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b So tcPolyBinds must be capable of dealing with nested polytypes; and so it is. See TcBinds.tcMonoBinds (with type-sig case). Note [Silly default-method bind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we pass the default method binding to the type checker, it must look like op2 = e not $dmop2 = e otherwise the "$dm" stuff comes out error messages. But we want the "$dm" to come out in the interface file. So we typecheck the former, and wrap it in a let, thus $dmop2 = let op2 = e in op2 This makes the error messages right. ************************************************************************ * * Error messages * * ************************************************************************ -} tcMkDeclCtxt :: TyClDecl Name -> SDoc tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl, ptext (sLit "declaration for"), quotes (ppr (tcdName decl))] tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside = addErrCtxt (tcMkDeclCtxt decl) thing_inside badMethodErr :: Outputable a => a -> Name -> SDoc badMethodErr clas op = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "does not have a method"), quotes (ppr op)] badGenericMethod :: Outputable a => a -> Name -> SDoc badGenericMethod clas op = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] {- badGenericInstanceType :: LHsBinds Name -> SDoc badGenericInstanceType binds = vcat [ptext (sLit "Illegal type pattern in the generic bindings"), nest 2 (ppr binds)] missingGenericInstances :: [Name] -> SDoc missingGenericInstances missing = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc dupGenericInsts tc_inst_infos = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"), nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), ptext (sLit "All the type patterns for a generic type constructor must be identical") ] where ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) -} badDmPrag :: Id -> Sig Name -> TcM () badDmPrag sel_id prag = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") <+> quotes (ppr sel_id) <+> ptext (sLit "lacks an accompanying binding")) warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc warningMinimalDefIncomplete mindef = vcat [ ptext (sLit "The MINIMAL pragma does not require:") , nest 2 (pprBooleanFormulaNice mindef) , ptext (sLit "but there is no default implementation.") ]