ghc/compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcClassDcl]{Typechecking class declarations}
   5
   6 \begin{code}
   7 module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
   8                     tcMethodBind, checkFromThisClass
   9                   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
  14                           InPat(..), HsBinds(..), GRHSs(..),
  15                           HsExpr(..), HsLit(..), HsType(..), HsPred(..),
  16                           pprHsClassAssertion, unguardedRHS,
  17                           andMonoBinds, andMonoBindList, getTyVarName,
  18                           isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
  19                         )
  20 import HsPragmas        ( ClassPragmas(..) )
  21 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
  22 import RnHsSyn          ( RenamedTyClDecl, RenamedClassPragmas,
  23                           RenamedClassOpSig, RenamedMonoBinds,
  24                           RenamedContext, RenamedHsDecl, RenamedSig
  25                         )
  26 import TcHsSyn          ( TcMonoBinds, idsToMonoBinds )
  27
  28 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
  29 import TcEnv            ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
  30                           tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
  31                           tcExtendLocalValEnv
  32                         )
  33 import TcBinds          ( tcBindWithSigs, tcSpecSigs )
  34 import TcTyDecls        ( mkNewTyConRep )
  35 import TcUnify          ( unifyKinds )
  36 import TcMonad
  37 import TcMonoType       ( kcHsType, tcHsTopType, tcExtendTopTyVarScope,
  38                           tcContext, checkSigTyVars, sigCtxt, mkTcSig
  39                         )
  40 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  41 import TcType           ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
  42 import TcInstUtil       ( classDataCon )
  43 import PrelInfo         ( nO_METHOD_BINDING_ERROR_ID )
  44 import FieldLabel       ( firstFieldLabelTag )
  45 import Bag              ( unionManyBags, bagToList )
  46 import Class            ( mkClass, classBigSig, classSelIds, Class, ClassOpItem )
  47 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
  48 import MkId             ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
  49 import DataCon          ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict )
  50 import Id               ( Id, setInlinePragma, idUnfolding, idType, idName )
  51 import CoreUnfold       ( unfoldingTemplate )
  52 import IdInfo
  53 import Name             ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
  54 import NameSet          ( emptyNameSet )
  55 import Outputable
  56 import Type             ( Type, ThetaType, ClassContext,
  57                           mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys,
  58                           mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
  59                           boxedTypeKind, mkArrowKind
  60                         )
  61 import Var              ( tyVarKind, TyVar )
  62 import VarSet           ( mkVarSet, emptyVarSet )
  63 import TyCon            ( AlgTyConFlavour(..), mkClassTyCon )
  64 import Unique           ( Unique, Uniquable(..) )
  65 import Util
  66 import Maybes           ( seqMaybe )
  67 import FiniteMap        ( lookupWithDefaultFM )
  68 \end{code}
  69
  70
  71
  72 Dictionary handling
  73 ~~~~~~~~~~~~~~~~~~~
  74 Every class implicitly declares a new data type, corresponding to dictionaries
  75 of that class. So, for example:
  76
  77         class (D a) => C a where
  78           op1 :: a -> a
  79           op2 :: forall b. Ord b => a -> b -> b
  80
  81 would implicitly declare
  82
  83         data CDict a = CDict (D a)
  84                              (a -> a)
  85                              (forall b. Ord b => a -> b -> b)
  86
  87 (We could use a record decl, but that means changing more of the existing apparatus.
  88 One step at at time!)
  89
  90 For classes with just one superclass+method, we use a newtype decl instead:
  91
  92         class C a where
  93           op :: forallb. a -> b -> b
  94
  95 generates
  96
  97         newtype CDict a = CDict (forall b. a -> b -> b)
  98
  99 Now DictTy in Type is just a form of type synomym:
 100         DictTy c t = TyConTy CDict `AppTy` t
 101
 102 Death to "ExpandingDicts".
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{Kind checking}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 \begin{code}
 112 kcClassDecl (ClassDecl  context class_name
 113                         tyvar_names fundeps class_sigs def_methods pragmas
 114                         _ _ _ _ src_loc)
 115   =         -- CHECK ARITY 1 FOR HASKELL 1.4
 116     checkTc (opt_GlasgowExts || length tyvar_names == 1)
 117             (classArityErr class_name)          `thenTc_`
 118
 119         -- Get the (mutable) class kind
 120     tcLookupTy class_name                       `thenNF_Tc` \ (kind, _, _) ->
 121
 122         -- Make suitable tyvars and do kind checking
 123         -- The net effect is to mutate the class kind
 124     tcExtendTopTyVarScope kind tyvar_names      $ \ _ _ ->
 125     tcContext context                           `thenTc_`
 126     mapTc kc_sig the_class_sigs                 `thenTc_`
 127
 128     returnTc ()
 129   where
 130     the_class_sigs = filter isClassOpSig class_sigs
 131
 132     kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty)
 133 \end{code}
 134
 135
 136 %************************************************************************
 137 %*                                                                      *
 138 \subsection{Type checking}
 139 %*                                                                      *
 140 %************************************************************************
 141
 142 \begin{code}
 143 tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
 144              (ClassDecl context class_name
 145                         tyvar_names fundeps class_sigs def_methods pragmas
 146                         tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
 147   =     -- LOOK THINGS UP IN THE ENVIRONMENT
 148     tcLookupTy class_name                               `thenTc` \ (class_kind, _, AClass rec_class) ->
 149     tcExtendTopTyVarScope class_kind tyvar_names        $ \ tyvars _ ->
 150         -- The class kind is by now immutable
 151
 152         -- CHECK THE CONTEXT
 153 --  traceTc (text "tcClassCtxt" <+> ppr class_name)     `thenTc_`
 154     tcClassContext class_name rec_class tyvars context sc_sel_names
 155                                                 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 156 --  traceTc (text "tcClassCtxt done" <+> ppr class_name)        `thenTc_`
 157
 158         -- CHECK THE FUNCTIONAL DEPENDENCIES,
 159     tcFundeps fundeps                           `thenTc` \ fds ->
 160
 161         -- CHECK THE CLASS SIGNATURES,
 162     mapTc (tcClassSig rec_env rec_class tyvars)
 163           (filter isClassOpSig class_sigs)
 164                                                 `thenTc` \ sig_stuff ->
 165
 166         -- MAKE THE CLASS OBJECT ITSELF
 167     let
 168         (op_tys, op_items) = unzip sig_stuff
 169         rec_class_inst_env = rec_inst_mapper rec_class
 170         clas = mkClass class_name tyvars fds
 171                        sc_theta sc_sel_ids op_items
 172                        tycon
 173                        rec_class_inst_env
 174
 175         dict_component_tys = sc_tys ++ op_tys
 176         new_or_data = case dict_component_tys of
 177                         [_]   -> NewTyCon (mkNewTyConRep tycon)
 178                         other -> DataTyCon
 179
 180         dict_con = mkDataCon datacon_name
 181                            [notMarkedStrict | _ <- dict_component_tys]
 182                            [{- No labelled fields -}]
 183                            tyvars
 184                            [{-No context-}]
 185                            [{-No existential tyvars-}] [{-Or context-}]
 186                            dict_component_tys
 187                            tycon dict_con_id dict_wrap_id
 188
 189         dict_con_id  = mkDataConId datacon_wkr_name dict_con
 190         dict_wrap_id = mkDataConWrapId dict_con
 191
 192         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
 193                                                          ppr tycon_name)
 194                                       tycon_name
 195
 196         tycon = mkClassTyCon tycon_name
 197                              class_kind
 198                              tyvars
 199                              argvrcs
 200                              dict_con           -- Constructors
 201                              clas               -- Yes!  It's a dictionary
 202                              new_or_data
 203     in
 204     returnTc clas
 205 \end{code}
 206
 207 \begin{code}
 208 tcFundeps = mapTc tc_fundep
 209 tc_fundep (us, vs) =
 210     mapTc tc_fd_tyvar us        `thenTc` \ us' ->
 211     mapTc tc_fd_tyvar vs        `thenTc` \ vs' ->
 212     returnTc (us', vs')
 213 tc_fd_tyvar v =
 214     tcLookupTy v `thenTc` \(_, _, thing) ->
 215     case thing of
 216         ATyVar tv -> returnTc tv
 217         -- ZZ else should fail more gracefully
 218 \end{code}
 219
 220 \begin{code}
 221 tcClassContext :: Name -> Class -> [TyVar]
 222                -> RenamedContext        -- class context
 223                -> [Name]                -- Names for superclass selectors
 224                -> TcM s (ClassContext,  -- the superclass context
 225                          [Type],        -- types of the superclass dictionaries
 226                          [Id])          -- superclass selector Ids
 227
 228 tcClassContext class_name rec_class rec_tyvars context sc_sel_names
 229   =     -- Check the context.
 230         -- The renamer has already checked that the context mentions
 231         -- only the type variable of the class decl.
 232
 233         -- For std Haskell check that the context constrains only tyvars
 234     (if opt_GlasgowExts then
 235         returnTc []
 236      else
 237         mapTc check_constraint context
 238     )                                   `thenTc_`
 239
 240     tcContext context                   `thenTc` \ sc_theta ->
 241
 242     let
 243        sc_theta' = classesOfPreds sc_theta
 244        sc_tys = mkDictTys sc_theta'
 245        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
 246     in
 247         -- Done
 248     returnTc (sc_theta', sc_tys, sc_sel_ids)
 249
 250   where
 251     rec_tyvar_tys = mkTyVarTys rec_tyvars
 252
 253     mk_super_id name dict_ty
 254         = mkDictSelId name rec_class ty
 255         where
 256           ty = mkForAllTys rec_tyvars $
 257                mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
 258
 259     check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
 260                                          (superClassErr class_name (c, tys))
 261
 262     is_tyvar (MonoTyVar _) = True
 263     is_tyvar other         = False
 264
 265
 266 tcClassSig :: ValueEnv          -- Knot tying only!
 267            -> Class                     -- ...ditto...
 268            -> [TyVar]                   -- The class type variable, used for error check only
 269            -> RenamedClassOpSig
 270            -> TcM s (Type,              -- Type of the method
 271                      ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
 272
 273
 274 tcClassSig rec_env rec_clas rec_clas_tyvars
 275            (ClassOpSig op_name dm_name explicit_dm
 276                        op_ty src_loc)
 277   = tcAddSrcLoc src_loc $
 278
 279         -- Check the type signature.  NB that the envt *already has*
 280         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 281
 282     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 283     -- and that it is not constrained by theta
 284 --  traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
 285     tcHsTopType op_ty                           `thenTc` \ local_ty ->
 286     let
 287         global_ty   = mkSigmaTy rec_clas_tyvars
 288                                 [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)]
 289                                 local_ty
 290
 291         -- Build the selector id and default method id
 292         sel_id      = mkDictSelId op_name rec_clas global_ty
 293         dm_id       = mkDefaultMethodId dm_name rec_clas global_ty
 294         final_dm_id = tcAddImportedIdInfo rec_env dm_id
 295     in
 296 --  traceTc (text "tcClassSig done" <+> ppr op_name)    `thenTc_`
 297     returnTc (local_ty, (sel_id, final_dm_id, explicit_dm))
 298 \end{code}
 299
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 The purpose of pass 2 is
 308 \begin{enumerate}
 309 \item
 310 to beat on the explicitly-provided default-method decls (if any),
 311 using them to produce a complete set of default-method decls.
 312 (Omitted ones elicit an error message.)
 313 \item
 314 to produce a definition for the selector function for each method
 315 and superclass dictionary.
 316 \end{enumerate}
 317
 318 Pass~2 only applies to locally-defined class declarations.
 319
 320 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 321 each local class decl.
 322
 323 \begin{code}
 324 tcClassDecls2 :: [RenamedHsDecl]
 325               -> NF_TcM s (LIE, TcMonoBinds)
 326
 327 tcClassDecls2 decls
 328   = foldr combine
 329           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 330           [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
 331   where
 332     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 333                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 334                       returnNF_Tc (lie1 `plusLIE` lie2,
 335                                    binds1 `AndMonoBinds` binds2)
 336 \end{code}
 337
 338 @tcClassDecl2@ is the business end of things.
 339
 340 \begin{code}
 341 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 342              -> NF_TcM s (LIE, TcMonoBinds)
 343
 344 tcClassDecl2 (ClassDecl context class_name
 345                         tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc)
 346
 347   | not (isLocallyDefined class_name)
 348   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 349
 350   | otherwise   -- It is locally defined
 351   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 352     tcAddSrcLoc src_loc                                   $
 353     tcLookupClass class_name                            `thenNF_Tc` \ clas ->
 354     tcDefaultMethodBinds clas default_binds class_sigs
 355 \end{code}
 356
 357 \begin{code}
 358 mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds)
 359 mkImplicitClassBinds classes
 360   = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
 361         -- The selector binds are already in the selector Id's unfoldings
 362   where
 363     (cls_ids_s, binds_s) = unzip (map mk_implicit classes)
 364
 365     mk_implicit clas = (all_cls_ids, binds)
 366                      where
 367                         dict_con    = classDataCon clas
 368                         all_cls_ids = dataConId dict_con : cls_ids
 369                         cls_ids     = dataConWrapId dict_con : classSelIds clas
 370
 371                         -- The wrapper and selectors get bindings, the worker does not
 372                         binds | isLocallyDefined clas = idsToMonoBinds cls_ids
 373                               | otherwise             = EmptyMonoBinds
 374 \end{code}
 375
 376 %************************************************************************
 377 %*                                                                      *
 378 \subsection[Default methods]{Default methods}
 379 %*                                                                      *
 380 %************************************************************************
 381
 382 The default methods for a class are each passed a dictionary for the
 383 class, so that they get access to the other methods at the same type.
 384 So, given the class decl
 385 \begin{verbatim}
 386 class Foo a where
 387         op1 :: a -> Bool
 388         op2 :: Ord b => a -> b -> b -> b
 389
 390         op1 x = True
 391         op2 x y z = if (op1 x) && (y < z) then y else z
 392 \end{verbatim}
 393 we get the default methods:
 394 \begin{verbatim}
 395 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 396 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 397
 398 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 399 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 400                   if (op1 a dfoo x) && (< b dord y z) then y else z
 401 \end{verbatim}
 402
 403 When we come across an instance decl, we may need to use the default
 404 methods:
 405 \begin{verbatim}
 406 instance Foo Int where {}
 407 \end{verbatim}
 408 gives
 409 \begin{verbatim}
 410 const.Foo.Int.op1 :: Int -> Bool
 411 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 412
 413 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 414 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 415
 416 dfun.Foo.Int :: Foo Int
 417 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 418 \end{verbatim}
 419 Notice that, as with method selectors above, we assume that dictionary
 420 application is curried, so there's no need to mention the Ord dictionary
 421 in const.Foo.Int.op2 (or the type variable).
 422
 423 \begin{verbatim}
 424 instance Foo a => Foo [a] where {}
 425
 426 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 427 dfun.Foo.List
 428   = /\ a -> \ dfoo_a ->
 429     let rec
 430         op1 = defm.Foo.op1 [a] dfoo_list
 431         op2 = defm.Foo.op2 [a] dfoo_list
 432         dfoo_list = (op1, op2)
 433     in
 434         dfoo_list
 435 \end{verbatim}
 436
 437 \begin{code}
 438 tcDefaultMethodBinds
 439         :: Class
 440         -> RenamedMonoBinds
 441         -> [RenamedSig]
 442         -> TcM s (LIE, TcMonoBinds)
 443
 444 tcDefaultMethodBinds clas default_binds sigs
 445   =     -- Check that the default bindings come from this class
 446     checkFromThisClass clas op_items default_binds      `thenNF_Tc_`
 447
 448         -- Do each default method separately
 449         -- For Hugs compatibility we make a default-method for every
 450         -- class op, regardless of whether or not the programmer supplied an
 451         -- explicit default decl for the class.  GHC will actually never
 452         -- call the default method for such operations, because it'll whip up
 453         -- a more-informative default method at each instance decl.
 454     mapAndUnzipTc tc_dm op_items                `thenTc` \ (defm_binds, const_lies) ->
 455
 456     returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
 457   where
 458     prags = filter isPragSig sigs
 459
 460     (tyvars, _, _, op_items) = classBigSig clas
 461
 462     origin = ClassDeclOrigin
 463
 464     -- We make a separate binding for each default method.
 465     -- At one time I used a single AbsBinds for all of them, thus
 466     --  AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 467     -- But that desugars into
 468     --  ds = \d -> (..., ..., ...)
 469     --  dm1 = \d -> case ds d of (a,b,c) -> a
 470     -- And since ds is big, it doesn't get inlined, so we don't get good
 471     -- default methods.  Better to make separate AbsBinds for each
 472
 473     tc_dm op_item@(_, dm_id, _)
 474       = tcInstTyVars tyvars             `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
 475         let
 476             theta = [(mkClassPred clas inst_tys)]
 477         in
 478         newDicts origin theta                   `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 479         let
 480             avail_insts = this_dict
 481         in
 482         tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 483             tcMethodBind clas origin clas_tyvars inst_tys theta
 484                          default_binds prags False
 485                          op_item
 486         )                                       `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
 487
 488         tcAddErrCtxt (defltMethCtxt clas) $
 489
 490             -- tcMethodBind has checked that the class_tyvars havn't
 491             -- been unified with each other or another type, but we must
 492             -- still zonk them before passing them to tcSimplifyAndCheck
 493         mapNF_Tc zonkTcTyVarBndr clas_tyvars    `thenNF_Tc` \ clas_tyvars' ->
 494
 495             -- Check the context
 496         tcSimplifyAndCheck
 497             (ptext SLIT("class") <+> ppr clas)
 498             (mkVarSet clas_tyvars')
 499             avail_insts
 500             insts_needed                        `thenTc` \ (const_lie, dict_binds) ->
 501
 502         let
 503             full_bind = AbsBinds
 504                             clas_tyvars'
 505                             [this_dict_id]
 506                             [(clas_tyvars', dm_id, local_dm_id)]
 507                             emptyNameSet        -- No inlines (yet)
 508                             (dict_binds `andMonoBinds` defm_bind)
 509         in
 510         returnTc (full_bind, const_lie)
 511 \end{code}
 512
 513 \begin{code}
 514 checkFromThisClass :: Class -> [ClassOpItem] -> RenamedMonoBinds -> NF_TcM s ()
 515 checkFromThisClass clas op_items mono_binds
 516   = mapNF_Tc check_from_this_class bndrs        `thenNF_Tc_`
 517     returnNF_Tc ()
 518   where
 519     check_from_this_class (bndr, loc)
 520           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 521           | otherwise                         = tcAddSrcLoc loc $
 522                                                 addErrTc (badMethodErr bndr clas)
 523     sel_names = [getOccName sel_id | (sel_id,_,_) <- op_items]
 524     bndrs = bagToList (collectMonoBinders mono_binds)
 525 \end{code}
 526
 527
 528 @tcMethodBind@ is used to type-check both default-method and
 529 instance-decl method declarations.  We must type-check methods one at a
 530 time, because their signatures may have different contexts and
 531 tyvar sets.
 532
 533 \begin{code}
 534 tcMethodBind
 535         :: Class
 536         -> InstOrigin
 537         -> [TcTyVar]            -- Instantiated type variables for the
 538                                 --  enclosing class/instance decl.
 539                                 --  They'll be signature tyvars, and we
 540                                 --  want to check that they don't get bound
 541         -> [TcType]             -- Instance types
 542         -> TcThetaType          -- Available theta; this could be used to check
 543                                 --  the method signature, but actually that's done by
 544                                 --  the caller;  here, it's just used for the error message
 545         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 546         -> [RenamedSig]         -- Pramgas (just for this one)
 547         -> Bool                 -- True <=> This method is from an instance declaration
 548         -> ClassOpItem          -- The method selector and default-method Id
 549         -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
 550
 551 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 552              meth_binds prags is_inst_decl
 553              (sel_id, dm_id, explicit_dm)
 554  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 555
 556    newMethod origin sel_id inst_tys     `thenNF_Tc` \ meth@(_, meth_id) ->
 557    mkTcSig meth_id loc                  `thenNF_Tc` \ sig_info ->
 558
 559    let
 560      meth_name       = idName meth_id
 561      maybe_user_bind = find_bind meth_name meth_binds
 562
 563      no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 564
 565      meth_bind = case maybe_user_bind of
 566                         Just bind -> bind
 567                         Nothing   -> mk_default_bind meth_name loc
 568
 569      meth_prags = find_prags meth_name prags
 570    in
 571
 572         -- Warn if no method binding, only if -fwarn-missing-methods
 573    warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm)
 574           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 575
 576         -- Check the bindings; first add inst_tyvars to the envt
 577         -- so that we don't quantify over them in nested places
 578         -- The *caller* put the class/inst decl tyvars into the envt
 579    tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
 580      tcAddErrCtxt (methodCtxt sel_id)           $
 581      tcBindWithSigs NotTopLevel meth_bind
 582                     [sig_info] meth_prags NonRecursive
 583    )                                            `thenTc` \ (binds, insts, _) ->
 584
 585
 586    tcExtendLocalValEnv [(meth_name, meth_id)] (
 587         tcSpecSigs meth_prags
 588    )                                            `thenTc` \ (prag_binds1, prag_lie) ->
 589
 590         -- The prag_lie for a SPECIALISE pragma will mention the function
 591         -- itself, so we have to simplify them away right now lest they float
 592         -- outwards!
 593    bindInstsOfLocalFuns prag_lie [meth_id]      `thenTc` \ (prag_lie', prag_binds2) ->
 594
 595
 596         -- Now check that the instance type variables
 597         -- (or, in the case of a class decl, the class tyvars)
 598         -- have not been unified with anything in the environment
 599    tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id))      $
 600    checkSigTyVars inst_tyvars emptyVarSet                                       `thenTc_`
 601
 602    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 603              insts `plusLIE` prag_lie',
 604              meth)
 605  where
 606    sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name
 607
 608    sel_name = idName sel_id
 609
 610         -- The renamer just puts the selector ID as the binder in the method binding
 611         -- but we must use the method name; so we substitute it here.  Crude but simple.
 612    find_bind meth_name (FunMonoBind op_name fix matches loc)
 613         | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
 614    find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
 615         | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
 616    find_bind meth_name (AndMonoBinds b1 b2)
 617                               = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
 618    find_bind meth_name other  = Nothing -- Default case
 619
 620
 621         -- Find the prags for this method, and replace the
 622         -- selector name with the method name
 623    find_prags meth_name [] = []
 624    find_prags meth_name (SpecSig name ty loc : prags)
 625         | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags
 626    find_prags meth_name (InlineSig name phase loc : prags)
 627         | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags
 628    find_prags meth_name (NoInlineSig name phase loc : prags)
 629         | name == sel_name = NoInlineSig meth_name phase loc : find_prags meth_name prags
 630    find_prags meth_name (prag:prags) = find_prags meth_name prags
 631
 632    mk_default_bind local_meth_name loc
 633       = PatMonoBind (VarPatIn local_meth_name)
 634                     (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
 635                     loc
 636
 637    default_expr loc
 638         | explicit_dm = HsVar (getName dm_id)   -- There's a default method
 639         | otherwise   = error_expr loc          -- No default method
 640
 641    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 642                           (HsLit (HsString (_PK_ (error_msg loc))))
 643
 644    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 645 \end{code}
 646
 647 Contexts and errors
 648 ~~~~~~~~~~~~~~~~~~~
 649 \begin{code}
 650 classArityErr class_name
 651   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 652
 653 superClassErr class_name sc
 654   = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
 655     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 656
 657 defltMethCtxt class_name
 658   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
 659
 660 methodCtxt sel_id
 661   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 662
 663 badMethodErr bndr clas
 664   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 665           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 666
 667 omittedMethodWarn sel_id clas
 668   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 669          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 670 \end{code}