X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=be9a07384505d5351da0f11091abc5d64d4df7ae;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=407f3d62c2a290a12032ff5778420a1ba986dc9d;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 407f3d6..be9a073 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcClassDcl]{Typechecking class declarations} @@ -9,63 +9,60 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) wh #include "HsVersions.h" import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..), - InPat(..), - andMonoBinds, collectMonoBinders, - getTyVarName + InPat(..), HsBinds(..), GRHSsAndBinds(..), + HsExpr(..), HsLit(..), HsType(..), pprClassAssertion, + unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName ) import HsPragmas ( ClassPragmas(..) ) -import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) ) -import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), - RenamedClassOpSig(..), RenamedMonoBinds, - RenamedGenPragmas(..), RenamedContext(..), RenamedHsDecl +import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) ) +import RnHsSyn ( RenamedClassDecl, RenamedClassPragmas, + RenamedClassOpSig, RenamedMonoBinds, + RenamedContext, RenamedHsDecl, RenamedSig ) -import TcHsSyn ( TcHsBinds, TcMonoBinds, TcExpr, - mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) +import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod ) -import TcEnv ( TcIdOcc(..), newLocalIds, tcAddImportedIdInfo, +import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo, tcLookupClass, tcLookupTyVar, - tcExtendGlobalTyVars ) -import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, sigThetaCtxt, TcSigInfo(..) ) -import TcKind ( unifyKinds, TcKind ) -import TcMonad -import TcMonoType ( tcHsType, tcContext ) -import TcSimplify ( tcSimplifyAndCheck ) -import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars, - zonkSigTyVar, tcInstSigTcType + tcExtendGlobalTyVars, tcExtendLocalValEnv ) -import PragmaInfo ( PragmaInfo(..) ) - -import Bag ( bagToList, unionManyBags ) +import TcBinds ( tcBindWithSigs, tcPragmaSigs ) +import TcUnify ( unifyKinds ) +import TcMonad +import TcMonoType ( tcHsType, tcContext, checkSigTyVars, sigCtxt, mkTcSig ) +import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) +import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr ) +import PrelVals ( nO_METHOD_BINDING_ERROR_ID ) +import FieldLabel ( firstFieldLabelTag ) +import Bag ( unionManyBags ) import Class ( mkClass, classBigSig, Class ) -import CmdLineOpts ( opt_PprUserLength, opt_GlasgowExts ) -import Id ( Id, StrictnessMark(..), - mkSuperDictSelId, mkMethodSelId, - mkDefaultMethodId, getIdUnfolding, mkDataCon, - idType +import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods ) +import MkId ( mkSuperDictSelId, mkDataConId, + mkMethodSelId, mkDefaultMethodId + ) +import DataCon ( mkDataCon ) +import Id ( Id, + getIdUnfolding, idType, idName ) import CoreUnfold ( getUnfoldingTemplate ) import IdInfo -import Name ( Name, isLocallyDefined, moduleString, getSrcLoc, - OccName, nameOccName, - nameString, NamedThing(..) ) +import Name ( Name, isLocallyDefined, NamedThing(..) ) import Outputable -import SrcLoc ( mkGeneratedSrcLoc ) -import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy, - mkForAllTy, mkSigmaTy, splitSigmaTy, mkForAllTys, Type, ThetaType +import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, + mkSigmaTy, mkForAllTys, Type, ThetaType, + boxedTypeKind, mkArrowKind ) -import TysWiredIn ( stringTy ) -import TyVar ( unitTyVarSet, tyVarSetToList, mkTyVarSet, tyVarKind, TyVar ) -import TyCon ( mkDataTyCon ) -import Kind ( mkBoxedTypeKind, mkArrowKind ) +import Var ( tyVarKind, TyVar ) +import VarSet ( mkVarSet ) +import TyCon ( mkAlgTyCon ) import Unique ( Unique, Uniquable(..) ) import Util -import Maybes ( assocMaybe, maybeToBool ) +import Maybes ( seqMaybe ) -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo, noIdInfo) \end{code} @@ -125,7 +122,7 @@ tcClassDecl1 rec_env rec_inst_mapper unifyKinds class_kinds tyvar_kinds `thenTc_` -- CHECK THE CONTEXT - tcClassContext rec_class rec_tyvars context pragmas + tcClassContext class_name rec_class rec_tyvars context pragmas `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, @@ -146,20 +143,21 @@ tcClassDecl1 rec_env rec_inst_mapper [_] -> NewType other -> DataType - dict_con_id = mkDataCon datacon_name + dict_con = mkDataCon datacon_name [NotMarkedStrict | _ <- dict_component_tys] [{- No labelled fields -}] rec_tyvars [{-No context-}] [{-No existential tyvars-}] [{-Or context-}] dict_component_tys - tycon + tycon dict_con_id + dict_con_id = mkDataConId dict_con - tycon = mkDataTyCon tycon_name - (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars) + tycon = mkAlgTyCon tycon_name + (foldr (mkArrowKind . tyVarKind) boxedTypeKind rec_tyvars) rec_tyvars [] -- No context - [dict_con_id] -- Constructors + [dict_con] -- Constructors [] -- No derivings (Just clas) -- Yes! It's a dictionary new_or_data @@ -170,24 +168,40 @@ tcClassDecl1 rec_env rec_inst_mapper \begin{code} -tcClassContext :: Class -> [TyVar] +tcClassContext :: Name -> Class -> [TyVar] -> RenamedContext -- class context -> RenamedClassPragmas -- pragmas for superclasses -> TcM s (ThetaType, -- the superclass context [Type], -- types of the superclass dictionaries [Id]) -- superclass selector Ids -tcClassContext rec_class rec_tyvars context pragmas +tcClassContext class_name rec_class rec_tyvars context pragmas = -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. + + -- For std Haskell check that the context constrains only tyvars + (if opt_GlasgowExts then + returnTc [] + else + mapTc check_constraint context + ) `thenTc_` + tcContext context `thenTc` \ sc_theta -> + let sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta] in -- Make super-class selector ids - mapTc mk_super_id sc_theta `thenTc` \ sc_sel_ids -> + -- We number them off, 1, 2, 3 etc so that we can construct + -- names for the selectors. Thus + -- class (C a, C b) => D a b where ... + -- gives superclass selectors + -- D_sc1, D_sc2 + -- (We used to call them D_C, but now we can have two different + -- superclasses both called C!) + mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids -> -- Done returnTc (sc_theta, sc_tys, sc_sel_ids) @@ -195,16 +209,22 @@ tcClassContext rec_class rec_tyvars context pragmas where rec_tyvar_tys = mkTyVarTys rec_tyvars - mk_super_id (super_class, tys) + mk_super_id ((super_class, tys), index) = tcGetUnique `thenNF_Tc` \ uniq -> let ty = mkForAllTys rec_tyvars $ mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys) in - returnTc (mkSuperDictSelId uniq rec_class super_class ty) + returnTc (mkSuperDictSelId uniq rec_class index ty) + + check_constraint (c, tys) = checkTc (all is_tyvar tys) + (superClassErr class_name (c, tys)) + is_tyvar (MonoTyVar _) = True + is_tyvar other = False -tcClassSig :: TcEnv s -- Knot tying only! + +tcClassSig :: GlobalValueEnv -- Knot tying only! -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only -> RenamedClassOpSig @@ -303,18 +323,19 @@ tcClassDecl2 (ClassDecl context class_name (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas -- The selector binds are already in the selector Id's unfoldings - sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id)) - | sel_id <- sc_sel_ids ++ op_sel_ids, - isLocallyDefined sel_id - ] - - final_sel_binds = andMonoBinds sel_binds +-- sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id)) +-- | sel_id <- sc_sel_ids ++ op_sel_ids, +-- isLocallyDefined sel_id +-- ] +-- +-- final_sel_binds = andMonoBindList sel_binds in -- Generate bindings for the default methods tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) -> - returnTc (const_insts, - final_sel_binds `AndMonoBinds` meth_binds) + returnTc (const_insts, meth_binds) +-- final_sel_binds `AndMonoBinds` meth_binds) +-- Leave 'em out for now. They always get inlined anyway. SLPJ June '98 \end{code} %************************************************************************ @@ -398,35 +419,17 @@ tcDefaultMethodBinds tcDefaultMethodBinds clas default_binds = -- Construct suitable signatures - tcInstSigTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) -> + tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) -> -- Typecheck the default bindings let - tc_dm meth_bind - | not (maybeToBool maybe_stuff) - = -- Binding for something that isn't in the class signature - failWithTc (badMethodErr bndr_name clas) - - | otherwise - = -- Normal case - tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind - `thenTc` \ (bind, insts, (_, local_dm_id)) -> + tc_dm sel_id_w_dm@(_, Just dm_id) + = tcMethodBind clas origin inst_tys clas_tyvars + default_binds [{-no prags-}] False + sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) -> returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id)) - where - bndr_name = case meth_bind of - FunMonoBind name _ _ _ -> name - PatMonoBind (VarPatIn name) _ _ -> name - - maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name) - assoc_list = [ (getOccName sel_id, pair) - | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids - ] - Just (sel_id, Just dm_id) = maybe_stuff - -- We're looking at a default-method binding, so the dm_id - -- is sure to be there! Hence the inner "Just". in - mapAndUnzip3Tc tc_dm - (flatten default_binds []) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) -> + mapAndUnzip3Tc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) -> -- Check the context newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> @@ -434,10 +437,15 @@ tcDefaultMethodBinds clas default_binds avail_insts = this_dict in tcAddErrCtxt (classDeclCtxt clas) $ - tcAddErrCtxtM (sigThetaCtxt avail_insts) $ - mapNF_Tc zonkSigTyVar clas_tyvars `thenNF_Tc` \ clas_tyvars' -> - tcSimplifyAndCheck (text "classDecl") - (mkTyVarSet clas_tyvars') + + -- tcMethodBind has checked that the class_tyvars havn't + -- been unified with each other or another type, but we must + -- still zonk them + mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' -> + + tcSimplifyAndCheck + (ptext SLIT("class") <+> ppr clas) + (mkVarSet clas_tyvars') avail_insts (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) -> @@ -446,17 +454,18 @@ tcDefaultMethodBinds clas default_binds clas_tyvars' [this_dict_id] abs_bind_stuff - (dict_binds `AndMonoBinds` andMonoBinds defm_binds) + (dict_binds `andMonoBinds` andMonoBindList defm_binds) in returnTc (const_lie, full_binds) where (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas - origin = ClassDeclOrigin - flatten EmptyMonoBinds rest = rest - flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest) - flatten a_bind rest = a_bind : rest + sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids] + -- Just the ones for which there is an explicit + -- user default declaration + + origin = ClassDeclOrigin \end{code} @tcMethodBind@ is used to type-check both default-method and @@ -468,41 +477,115 @@ tyvar sets. tcMethodBind :: Class -> InstOrigin s - -> [TcType s] -- Instance types - -> [TcTyVar s] -- Free variables of those instance types - -- they'll be signature tyvars, and we - -- want to check that they don't bound - -> Id -- The method selector - -> RenamedMonoBinds -- Method binding (just one) + -> [TcType s] -- Instance types + -> [TcTyVar s] -- Free variables of those instance types + -- they'll be signature tyvars, and we + -- want to check that they don't bound + -> RenamedMonoBinds -- Method binding (pick the right one from in here) + -> [RenamedSig] -- Pramgas (just for this one) + -> Bool -- True <=> supply default decl if no explicit decl + -- This is true for instance decls, + -- false for class decls + -> (Id, Maybe Id) -- The method selector and default-method Id -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s)) -tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind - = tcAddSrcLoc src_loc $ - newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) -> - tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') -> +tcMethodBind clas origin inst_tys inst_tyvars + meth_binds prags supply_default_bind + (sel_id, maybe_dm_id) + = tcGetSrcLoc `thenNF_Tc` \ loc -> + + newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) -> + mkTcSig meth_id loc `thenNF_Tc` \ sig_info -> + let - (theta', tau') = splitRhoTy rho_ty' - sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc + meth_name = idName meth_id + maybe_user_bind = find_bind meth_name meth_binds + + no_user_bind = case maybe_user_bind of {Nothing -> True; other -> False} + no_user_default = case maybe_dm_id of {Nothing -> True; other -> False} + + meth_bind = case maybe_user_bind of + Just bind -> bind + Nothing -> mk_default_bind meth_name loc + + meth_prags = find_prags meth_name prags in - tcExtendGlobalTyVars inst_tyvars ( + + -- Warn if no method binding, only if -fwarn-missing-methods + if no_user_bind && not supply_default_bind then + pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys) + else + warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default) + (omittedMethodWarn sel_id clas) `thenNF_Tc_` + + -- Check the pragmas + tcExtendLocalValEnv [meth_name] [meth_id] ( + tcPragmaSigs meth_prags + ) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) -> + + -- Check the bindings + tcExtendGlobalTyVars (mkVarSet inst_tyvars) ( tcAddErrCtxt (methodCtxt sel_id) $ - tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info] - NonRecursive (\_ -> NoPragmaInfo) + tcBindWithSigs NotTopLevel meth_bind [sig_info] + NonRecursive prag_info_fn ) `thenTc` \ (binds, insts, _) -> + + -- The prag_lie for a SPECIALISE pragma will mention the function + -- itself, so we have to simplify them away right now lest they float + -- outwards! + bindInstsOfLocalFuns prag_lie [meth_id] `thenTc` \ (prag_lie', prag_binds2) -> + + -- Now check that the instance type variables -- (or, in the case of a class decl, the class tyvars) -- have not been unified with anything in the environment - tcAddErrCtxt (monoCtxt sel_id) ( - tcAddErrCtxt (sigCtxt sel_id) $ - checkSigTyVars inst_tyvars (idType local_meth_id) - ) `thenTc_` + tcAddErrCtxtM (sigCtxt (quotes (ppr sel_id)) (idType meth_id)) ( + checkSigTyVars inst_tyvars `thenTc_` + + returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, + insts `plusLIE` prag_lie', + meth)) - returnTc (binds, insts, meth) where - (bndr_name, src_loc) = case meth_bind of - FunMonoBind name _ _ loc -> (name, loc) - PatMonoBind (VarPatIn name) _ loc -> (name, loc) + sel_name = idName sel_id + + -- The renamer just puts the selector ID as the binder in the method binding + -- but we must use the method name; so we substitute it here. Crude but simple. + find_bind meth_name (FunMonoBind op_name fix matches loc) + | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc) + find_bind meth_name (PatMonoBind (VarPatIn op_name) rhs loc) + | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) rhs loc) + find_bind meth_name (AndMonoBinds b1 b2) + = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2 + find_bind meth_name other = Nothing -- Default case + + + -- Find the prags for this method, and replace the + -- selector name with the method name + find_prags meth_name [] = [] + find_prags meth_name (SpecSig name ty spec loc : prags) + | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags + find_prags meth_name (InlineSig name loc : prags) + | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags + find_prags meth_name (NoInlineSig name loc : prags) + | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags + find_prags meth_name (prag:prags) = find_prags meth_name prags + + mk_default_bind local_meth_name loc + = PatMonoBind (VarPatIn local_meth_name) + (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds) + loc + + default_expr loc + = case maybe_dm_id of + Just dm_id -> HsVar (getName dm_id) -- There's a default method + Nothing -> error_expr loc -- No default method + + error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) + (HsLit (HsString (_PK_ (error_msg loc)))) + + error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) \end{code} Contexts and errors @@ -514,15 +597,18 @@ classArityErr class_name classDeclCtxt class_name = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name) +superClassErr class_name sc + = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc) + <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) + methodCtxt sel_id = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id) -monoCtxt sel_id - = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id), - nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction")) - ] - badMethodErr bndr clas = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)] + +omittedMethodWarn sel_id clas + = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id), + ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)] \end{code}