\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
+module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2,
+ tcMethodBind, checkFromThisClass
+ ) where
#include "HsVersions.h"
InPat(..), HsBinds(..), GRHSs(..),
HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
- isClassDecl, isClassOpSig
+ isClassDecl, isClassOpSig, collectMonoBinders
)
import HsPragmas ( ClassPragmas(..) )
-import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
+import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedHsDecl, RenamedSig
)
import TcHsSyn ( TcMonoBinds )
-import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
+import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv
)
-import TcBinds ( tcBindWithSigs, tcPragmaSigs )
+import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcUnify ( unifyKinds )
import TcMonad
import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
)
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
-import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
+import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import FieldLabel ( firstFieldLabelTag )
-import Bag ( unionManyBags )
+import Bag ( unionManyBags, bagToList )
import Class ( mkClass, classBigSig, Class )
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 MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId )
+import DataCon ( mkDataCon, notMarkedStrict )
+import Id ( Id, setInlinePragma, getIdUnfolding, idType, idName )
+import CoreUnfold ( unfoldingTemplate )
import IdInfo
-import Name ( Name, isLocallyDefined, NamedThing(..) )
+import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
+import NameSet ( emptyNameSet )
import Outputable
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkSigmaTy, mkForAllTys, Type, ThetaType,
import Util
import Maybes ( seqMaybe )
import FiniteMap ( lookupWithDefaultFM )
-
-
--- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
-tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
- noIdInfo)
\end{code}
\begin{code}
kcClassDecl (ClassDecl context class_name
tyvar_names class_sigs def_methods pragmas
- tycon_name datacon_name src_loc)
+ tycon_name datacon_name sc_sel_names src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
checkTc (opt_GlasgowExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
(ClassDecl context class_name
tyvar_names class_sigs def_methods pragmas
- tycon_name datacon_name src_loc)
+ tycon_name datacon_name sc_sel_names src_loc)
= -- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) ->
tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
-- CHECK THE CONTEXT
-- traceTc (text "tcClassCtxt" <+> ppr class_name) `thenTc_`
- tcClassContext class_name rec_class tyvars context pragmas
+ tcClassContext class_name rec_class tyvars context sc_sel_names
`thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
-- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_`
other -> DataType
dict_con = mkDataCon datacon_name
- [NotMarkedStrict | _ <- dict_component_tys]
+ [notMarkedStrict | _ <- dict_component_tys]
[{- No labelled fields -}]
tyvars
[{-No context-}]
[{-No existential tyvars-}] [{-Or context-}]
dict_component_tys
tycon dict_con_id
+
+ -- In general, constructors don't have to be inlined, but this one
+ -- does, because we don't make a top level binding for it.
dict_con_id = mkDataConId dict_con
+ `setInlinePragma` IMustBeINLINEd
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
ppr tycon_name)
\begin{code}
tcClassContext :: Name -> Class -> [TyVar]
-> RenamedContext -- class context
- -> RenamedClassPragmas -- pragmas for superclasses
+ -> [Name] -- Names for superclass selectors
-> TcM s (ThetaType, -- the superclass context
[Type], -- types of the superclass dictionaries
[Id]) -- superclass selector Ids
-tcClassContext class_name rec_class rec_tyvars context pragmas
+tcClassContext class_name rec_class rec_tyvars context sc_sel_names
= -- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
let
sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
+ sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
in
-
- -- Make super-class selector 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)
where
rec_tyvar_tys = mkTyVarTys rec_tyvars
- 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 index ty)
+ mk_super_id name dict_ty
+ = mkDictSelId name rec_class ty
+ where
+ ty = mkForAllTys rec_tyvars $
+ mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
check_constraint (c, tys) = checkTc (all is_tyvar tys)
(superClassErr class_name (c, tys))
local_ty
-- Build the selector id and default method id
- sel_id = mkMethodSelId op_name rec_clas global_ty
+ sel_id = mkDictSelId op_name rec_clas global_ty
maybe_dm_id = case maybe_dm_name of
Nothing -> Nothing
Just dm_name -> let
-> NF_TcM s (LIE, TcMonoBinds)
tcClassDecl2 (ClassDecl context class_name
- tyvar_names class_sigs default_binds pragmas _ _ src_loc)
+ tyvar_names class_sigs default_binds pragmas _ _ _ src_loc)
| not (isLocallyDefined class_name)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
(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 sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
--- | sel_id <- sc_sel_ids ++ op_sel_ids,
--- isLocallyDefined sel_id
--- ]
---
--- final_sel_binds = andMonoBindList sel_binds
+ sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id))
+ | sel_id <- sc_sel_ids ++ op_sel_ids
+ ]
in
-- Generate bindings for the default methods
tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, 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
+ returnTc (const_insts,
+ meth_binds `AndMonoBinds` andMonoBindList sel_binds)
\end{code}
%************************************************************************
defm.Foo.op1 :: forall a. Foo a => a -> Bool
defm.Foo.op1 = /\a -> \dfoo -> \x -> True
-====================== OLD ==================
-\begin{verbatim}
-defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
-defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
- if (op1 a dfoo x) && (< b dord y z) then y else z
-\end{verbatim}
-Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
-====================== END OF OLD ===================
-
-NEW:
-\begin{verbatim}
defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
if (op1 a dfoo x) && (< b dord y z) then y else z
\end{verbatim}
-
When we come across an instance decl, we may need to use the default
methods:
\begin{verbatim}
-> TcM s (LIE, TcMonoBinds)
tcDefaultMethodBinds clas default_binds
- = -- Construct suitable signatures
- tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
-
- -- Typecheck the default bindings
- let
- theta = [(clas,inst_tys)]
- tc_dm sel_id_w_dm@(_, Just dm_id)
- = tcMethodBind clas origin clas_tyvars inst_tys theta
- default_binds [{-no prags-}] False
- sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) ->
- returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id))
- in
- tcExtendTyVarEnvForMeths tyvars clas_tyvars (
- mapAndUnzip3Tc tc_dm sel_ids_w_dms
- ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
-
+ = -- Check that the default bindings come from this class
+ checkFromThisClass clas op_sel_ids default_binds `thenNF_Tc_`
- -- Check the context
- newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
- let
- avail_insts = this_dict
- in
- tcAddErrCtxt (defltMethCtxt clas) $
-
- -- tcMethodBind has checked that the class_tyvars havn't
- -- been unified with each other or another type, but we must
- -- still zonk them before passing them to tcSimplifyAndCheck
- 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) ->
-
- let
- full_binds = AbsBinds
- clas_tyvars'
- [this_dict_id]
- abs_bind_stuff
- (dict_binds `andMonoBinds` andMonoBindList defm_binds)
- in
- returnTc (const_lie, full_binds)
+ -- Do each default method separately
+ mapAndUnzipTc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, const_lies) ->
+ returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
where
+
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
-- user default declaration
origin = ClassDeclOrigin
+
+ -- 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
+
+ tc_dm sel_id_w_dm@(_, Just dm_id)
+ = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
+ let
+ theta = [(clas,inst_tys)]
+ in
+ newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ let
+ avail_insts = this_dict
+ in
+ tcExtendTyVarEnvForMeths tyvars clas_tyvars (
+ tcMethodBind clas origin clas_tyvars inst_tys theta
+ default_binds [{-no prags-}] False
+ sel_id_w_dm
+ ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
+
+ tcAddErrCtxt (defltMethCtxt clas) $
+
+ -- tcMethodBind has checked that the class_tyvars havn't
+ -- been unified with each other or another type, but we must
+ -- still zonk them before passing them to tcSimplifyAndCheck
+ mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
+
+ -- Check the context
+ tcSimplifyAndCheck
+ (ptext SLIT("class") <+> ppr clas)
+ (mkVarSet clas_tyvars')
+ avail_insts
+ insts_needed `thenTc` \ (const_lie, dict_binds) ->
+
+ let
+ full_bind = AbsBinds
+ clas_tyvars'
+ [this_dict_id]
+ [(clas_tyvars', dm_id, local_dm_id)]
+ emptyNameSet -- No inlines (yet)
+ (dict_binds `andMonoBinds` defm_bind)
+ in
+ returnTc (full_bind, const_lie)
\end{code}
+\begin{code}
+checkFromThisClass :: Class -> [Id] -> RenamedMonoBinds -> NF_TcM s ()
+checkFromThisClass clas op_sel_ids mono_binds
+ = mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
+ returnNF_Tc ()
+ where
+ check_from_this_class (bndr, loc)
+ | nameOccName bndr `elem` sel_names = returnNF_Tc ()
+ | otherwise = tcAddSrcLoc loc $
+ addErrTc (badMethodErr bndr clas)
+ sel_names = map getOccName op_sel_ids
+ bndrs = bagToList (collectMonoBinders mono_binds)
+\end{code}
+
+
@tcMethodBind@ is used to type-check both default-method and
instance-decl method declarations. We must type-check methods one at a
time, because their signatures may have different contexts and
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; first add inst_tyvars to the envt
-- so that we don't quantify over them in nested places
-- The *caller* put the class/inst decl tyvars into the envt
tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
tcAddErrCtxt (methodCtxt sel_id) $
- tcBindWithSigs NotTopLevel meth_bind [sig_info]
- NonRecursive prag_info_fn
+ tcBindWithSigs NotTopLevel meth_bind
+ [sig_info] meth_prags NonRecursive
) `thenTc` \ (binds, insts, _) ->
+ tcExtendLocalValEnv [(meth_name, meth_id)] (
+ tcSpecSigs meth_prags
+ ) `thenTc` \ (prag_binds1, prag_lie) ->
+
-- 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!
-- 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 (SpecSig name ty loc : prags)
+ | name == sel_name = SpecSig meth_name ty 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)
projects / ghc-hetmet.git / blobdiff