module TcInstDcls (
tcInstDecls1,
- tcInstDecls2,
- tcMethodBind
+ tcInstDecls2
) where
mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
-import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..), checkSigTyVars )
+import TcBinds ( tcPragmaSigs )
+import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
concatBag, foldBag, bagToList, listToBag,
Bag )
-import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals,
- opt_OmitDefaultInstanceMethods, opt_PprUserLength,
- opt_SpecialiseOverloaded
+import CmdLineOpts ( opt_GlasgowExts,
+ opt_PprUserLength, opt_SpecialiseOverloaded,
+ opt_WarnMissingMethods
)
import Class ( GenClass,
classBigSig,
isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust, seqMaybe, catMaybes )
-import Name ( nameOccName, getOccString, occNameString, moduleString, getSrcLoc,
+import Name ( nameOccName, getSrcLoc, mkLocalName,
isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
NamedThing(..)
)
in
-- Handle "derived" instances; note that we only do derivings
-- for things in this module; we ignore deriving decls from
- -- interfaces! We pass fixities, because they may be used
- -- in deriving Read and Show.
+ -- interfaces!
tcDeriving mod_name rn_name_supply decl_inst_info
`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
-- ...[NB May 97; all ignored except INLINE]
tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
- -- Check the method bindings
+ -- Check that all the method bindings come from this class
let
inst_tyvars_set' = mkTyVarSet inst_tyvars'
check_from_this_class (bndr, loc)
| nameOccName bndr `elem` sel_names = returnTc ()
| otherwise = recoverTc (returnTc ()) $
tcAddSrcLoc loc $
- failTc (instBndrErr bndr clas)
+ failTc (badMethodErr bndr clas)
sel_names = map getOccName op_sel_ids
in
mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_`
+
+ -- Type check the method bindings themselves
tcExtendGlobalTyVars inst_tyvars_set' (
tcExtendGlobalValEnv (catMaybes defm_ids) $
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcMethodBind clas inst_ty' monobinds)
+
+ mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds)
(op_sel_ids `zip` defm_ids)
- ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
+ ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
-- Check the overloading constraints of the methods and superclasses
let
%************************************************************************
\begin{code}
-tcMethodBind
+tcInstMethodBind
:: Class
-> TcType s -- Instance type
-> RenamedMonoBinds -- Method binding
-> (Id, Maybe Id) -- Selector id and default-method id
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
-tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
- = newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
- tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
+tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
let
- meth_name = getName local_meth_id
-
- maybe_meth_bind = go (getOccName sel_id) meth_binds
- (bndr_name, op_bind) = case maybe_meth_bind of
+ meth_occ = getOccName sel_id
+ default_meth_name = mkLocalName uniq meth_occ loc
+ maybe_meth_bind = find meth_occ meth_binds
+ the_meth_bind = case maybe_meth_bind of
Just stuff -> stuff
- Nothing -> (meth_name, mk_default_bind meth_name)
-
- (theta', tau') = splitRhoTy rho_ty'
- sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' noSrcLoc
+ Nothing -> mk_default_bind default_meth_name
in
- -- Warn if no method binding
- warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id))
- (omittedMethodWarn sel_id clas) `thenNF_Tc_`
-
- tcBindWithSigs [bndr_name] op_bind [sig_info]
- nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
+ -- Warn if no method binding, only if -fwarn-missing-methods
+
+ warnTc (opt_WarnMissingMethods &&
+ not (maybeToBool maybe_meth_bind) &&
+ not (maybeToBool maybe_dm_id))
+ (omittedMethodWarn sel_id clas) `thenNF_Tc_`
- returnTc (binds, insts, meth)
+ -- Typecheck the method binding
+ tcMethodBind clas origin inst_ty sel_id the_meth_bind
where
origin = InstanceDeclOrigin -- Poor
- go occ EmptyMonoBinds = Nothing
- go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2
+ find occ EmptyMonoBinds = Nothing
+ find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
- go occ b@(FunMonoBind op_name _ _ locn) | nameOccName op_name == occ = Just (op_name, b)
- | otherwise = Nothing
- go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
- | otherwise = Nothing
- go occ other = panic "Urk! Bad instance method binding"
+ find occ b@(FunMonoBind op_name _ _ _) | nameOccName op_name == occ = Just b
+ | otherwise = Nothing
+ find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
+ | otherwise = Nothing
+ find occ other = panic "Urk! Bad instance method binding"
mk_default_bind local_meth_name
where
rest_of_msg = ptext SLIT("cannot be used as an instance type")
-instBndrErr bndr clas sty
- = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
-
derivingWhenInstanceExistsErr clas tycon sty
= hang (hsep [ptext SLIT("Deriving class"),
ppr sty clas,
ppr sty inst_ty])
omittedMethodWarn sel_id clas sty
- = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id,
+ = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> ppr sty sel_id,
ptext SLIT("in an instance declaration for") <+> ppr sty clas]
instMethodNotInClassErr occ clas sty
projects / ghc-hetmet.git / blobdiff