diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl/Class.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Class.hs | 554 |
1 files changed, 554 insertions, 0 deletions
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs new file mode 100644 index 0000000000..55105f84ff --- /dev/null +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -0,0 +1,554 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +-- | Typechecking class declarations +module GHC.Tc.TyCl.Class + ( tcClassSigs + , tcClassDecl2 + , findMethodBind + , instantiateMethod + , tcClassMinimalDef + , HsSigFun + , mkHsSigFun + , badMethodErr + , instDeclCtxt1 + , instDeclCtxt2 + , instDeclCtxt3 + , tcATDefault + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Hs +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Sig +import GHC.Tc.Types.Evidence ( idHsWrapper ) +import GHC.Tc.Gen.Bind +import GHC.Tc.Utils.Unify +import GHC.Tc.Gen.HsType +import GHC.Tc.Utils.TcMType +import GHC.Core.Type ( piResultTys ) +import GHC.Core.Predicate +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad +import GHC.Driver.Phases (HscSource(..)) +import GHC.Tc.TyCl.Build( TcMethInfo ) +import GHC.Core.Class +import GHC.Core.Coercion ( pprCoAxiom ) +import GHC.Driver.Session +import GHC.Tc.Instance.Family +import GHC.Core.FamInstEnv +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Var.Env +import Outputable +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import Maybes +import GHC.Types.Basic +import Bag +import FastString +import BooleanFormula +import Util + +import Control.Monad +import Data.List ( mapAccumL, partition ) + +{- +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 a 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 +* * +************************************************************************ +-} + +illegalHsigDefaultMethod :: Name -> SDoc +illegalHsigDefaultMethod n = + text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" + +tcClassSigs :: Name -- Name of the class + -> [LSig GhcRn] + -> LHsBinds GhcRn + -> TcM [TcMethInfo] -- Exactly one for each method +tcClassSigs clas sigs def_methods + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env :: NameEnv (SrcSpan, Type) + gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- concatMapM (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) + + ; tcg_env <- getGblEnv + ; if tcg_src tcg_env == HsigFile + then + -- Error if we have value bindings + -- (Generic signatures without value bindings indicate + -- that a default of this form is expected to be + -- provided.) + when (not (null def_methods)) $ + failWithTc (illegalHsigDefaultMethod clas) + else + -- Error for each generic signature without value binding + sequence_ [ failWithTc (badGenericMethod clas n) + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] + + ; traceTc "tcClassSigs 2" (ppr clas) + ; return op_info } + where + vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True 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] + + skol_info = TyConSkol ClassFlavour clas + + tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) + -> TcM [TcMethInfo] + tc_sig gen_dm_env (op_names, op_hs_ty) + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType skol_info op_names op_hs_ty + -- Class tyvars already in scope + + ; traceTc "ClsSig 2" (ppr op_names) + ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } + where + f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty) + | nm `elem` dm_bind_names = Just VanillaDM + | otherwise = Nothing + + tc_gen_sig (op_names, gen_hs_ty) + = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty + ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } + +{- +************************************************************************ +* * + Class Declarations +* * +************************************************************************ +-} + +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration + -> TcM (LHsBinds GhcTcId) + +tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, + tcdMeths = default_binds})) + = recoverM (return emptyLHsBinds) $ + setSrcSpan (getLoc class_name) $ + 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 = 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 GhcRn + -> HsSigFun -> TcPragEnv -> ClassOpItem + -> TcM (LHsBinds GhcTcId) +-- Generate code for default methods +-- 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 _ _ _ _ _ prag_fn (sel_id, Nothing) + = do { -- No default method + mapM_ (addLocM (badDmPrag sel_id)) + (lookupPragEnv prag_fn (idName sel_id)) + ; return emptyBag } + +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn + (sel_id, Just (dm_name, dm_spec)) + | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn + = do { -- First look up the default method; it should be there! + -- It can be the ordinary default method + -- or the generic-default method. E.g of the latter + -- class C a where + -- op :: a -> a -> Bool + -- default op :: Eq a => a -> a -> Bool + -- op x y = x==y + -- The default method we generate is + -- $gm :: (C a, Eq a) => a -> a -> Bool + -- $gm x y = x==y + + global_dm_id <- tcLookupId dm_name + ; global_dm_id <- addInlinePrags global_dm_id prags + ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; spec_prags <- discardConstraints $ + tcSpecPrags global_dm_id prags + ; warnTc NoReason + (not (null spec_prags)) + (text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name)) + + ; let hs_ty = 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 + + warn_redundant = case dm_spec of + GenericDM {} -> True + VanillaDM -> False + -- For GenericDM, warn if the user specifies a signature + -- with redundant constraints; but not for VanillaDM, where + -- the default method may well be 'error' or something + + ctxt = FunSigCtxt sel_name warn_redundant + + ; let local_dm_id = mkLocalId local_dm_name local_dm_ty + local_dm_sig = CompleteSig { sig_bndr = local_dm_id + , sig_ctxt = ctxt + , sig_loc = getLoc (hsSigType hs_ty) } + + ; (ev_binds, (tc_bind, _)) + <- checkConstraints skol_info tyvars [this_dict] $ + tcPolyCheck no_prag_fn local_dm_sig + (L bind_loc lm_bind) + + ; let export = ABE { abe_ext = noExtField + , abe_poly = global_dm_id + , abe_mono = local_dm_id + , abe_wrap = idHsWrapper + , abe_prags = IsDefaultMethod } + full_bind = AbsBinds { abs_ext = noExtField + , abs_tvs = tyvars + , abs_ev_vars = [this_dict] + , abs_exports = [export] + , abs_ev_binds = [ev_binds] + , abs_binds = tc_bind + , abs_sig = True } + + ; return (unitBag (L bind_loc full_bind)) } + + | otherwise = pprPanic "tcDefMeth" (ppr sel_id) + where + skol_info = TyConSkol ClassFlavour (getName clas) + sel_name = idName sel_id + no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; + -- they are all for meth_id + +--------------- +tcClassMinimalDef :: Name -> [LSig GhcRn] -> [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 + tcg_env <- getGblEnv + -- However, only do this test when it's not an hsig file, + -- since you can't write a default implementation. + when (tcg_src tcg_env /= HsigFile) $ + whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ + (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) + return mindef + where + -- By default require all methods without a default implementation + defMindef :: ClassMinimalDef + defMindef = mkAnd [ noLoc (mkVar name) + | (name, _, Nothing) <- op_info ] + +instantiateMethod :: Class -> TcId -> [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 + rho_ty = piResultTys (idType sel_id) inst_tys + (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 = Name -> Maybe (LHsSigType GhcRn) + +mkHsSigFun :: [LSig GhcRn] -> HsSigFun +mkHsSigFun sigs = lookupNameEnv env + where + env = mkHsSigEnv get_classop_sig sigs + + get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) + get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) + get_classop_sig _ = Nothing + +--------------------------- +findMethodBind :: Name -- Selector + -> LHsBinds GhcRn -- A group of bindings + -> TcPragEnv + -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn]) + -- Returns the binding, the binding + -- site of the method binder, and any inline or + -- specialisation pragmas +findMethodBind sel_name binds prag_fn + = foldl' mplus Nothing (mapBag f binds) + where + prags = lookupPragEnv prag_fn sel_name + + f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) + | op_name == sel_name + = Just (bind, bndr_loc, prags) + f _other = Nothing + +--------------------------- +findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef +findMinimalDef = firstJusts . map toMinimalDef + where + toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef + toMinimalDef (L _ (MinimalSig _ _ (L _ 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 GHC.Tc.Gen.Bind.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 +* * +************************************************************************ +-} + +badMethodErr :: Outputable a => a -> Name -> SDoc +badMethodErr clas op + = hsep [text "Class", quotes (ppr clas), + text "does not have a method", quotes (ppr op)] + +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] + +{- +badGenericInstanceType :: LHsBinds Name -> SDoc +badGenericInstanceType binds + = vcat [text "Illegal type pattern in the generic bindings", + nest 2 (ppr binds)] + +missingGenericInstances :: [Name] -> SDoc +missingGenericInstances missing + = text "Missing type patterns for" <+> pprQuotedList missing + +dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc +dupGenericInsts tc_inst_infos + = vcat [text "More than one type pattern for a single generic type constructor:", + nest 2 (vcat (map ppr_inst_ty tc_inst_infos)), + text "All the type patterns for a generic type constructor must be identical" + ] + where + ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) +-} +badDmPrag :: TcId -> Sig GhcRn -> TcM () +badDmPrag sel_id prag + = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method") + <+> quotes (ppr sel_id) + <+> text "lacks an accompanying binding") + +warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc +warningMinimalDefIncomplete mindef + = vcat [ text "The MINIMAL pragma does not require:" + , nest 2 (pprBooleanFormulaNice mindef) + , text "but there is no default implementation." ] + +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = instDeclCtxt3 cls tys + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +instDeclCtxt3 :: Class -> [Type] -> SDoc +instDeclCtxt3 cls cls_tys + = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (text "In the instance declaration for") + 2 (quotes doc) + +tcATDefault :: SrcSpan + -> TCvSubst + -> NameSet + -> ClassATItem + -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instantiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just (rhs_ty, _loc) <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTyUnchecked subst' rhs_ty + tcv' = tyCoVarsOfTypesList pat_tys' + (tv', cv') = partition isTyVar tcv' + tvs' = scopedSort tv' + cvs' = scopedSort cv' + ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' + fam_tc pat_tys' rhs' + -- NB: no validity check. We check validity of default instances + -- in the class definition. Because type instance arguments cannot + -- be type family applications and cannot be polytypes, the + -- validity check is redundant. + + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingAT (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) + +warnMissingAT :: Name -> TcM () +warnMissingAT name + = do { warn <- woptM Opt_WarnMissingMethods + ; traceTc "warn" (ppr name <+> ppr warn) + ; hsc_src <- fmap tcg_src getGblEnv + -- Warn only if -Wmissing-methods AND not a signature + ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile) + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name)) } |