ghc/compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcClassDcl]{Typechecking class declarations}
   5
   6 \begin{code}
   7 module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
  12                           InPat(..), HsBinds(..), GRHSsAndBinds(..), GRHS(..),
  13                           HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
  14                           unguardedRHS, andMonoBinds, getTyVarName
  15                         )
  16 import HsPragmas        ( ClassPragmas(..) )
  17 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
  18 import RnHsSyn          ( RenamedClassDecl, RenamedClassPragmas,
  19                           RenamedClassOpSig, RenamedMonoBinds,
  20                           RenamedContext, RenamedHsDecl, RenamedSig
  21                         )
  22 import TcHsSyn          ( TcMonoBinds )
  23
  24 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
  25 import TcEnv            ( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo,
  26                           tcLookupClass, tcLookupTyVar,
  27                           tcExtendGlobalTyVars, tcExtendLocalValEnv
  28                         )
  29 import TcBinds          ( tcBindWithSigs, bindInstsOfLocalFuns,
  30                           checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..)
  31                         )
  32 import TcKind           ( unifyKinds, TcKind )
  33 import TcMonad
  34 import TcMonoType       ( tcHsType, tcContext )
  35 import TcSimplify       ( tcSimplifyAndCheck )
  36 import TcType           ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
  37                           zonkSigTyVar, tcInstSigTcType
  38                         )
  39 import PrelVals         ( nO_METHOD_BINDING_ERROR_ID )
  40 import FieldLabel       ( firstFieldLabelTag )
  41 import Bag              ( unionManyBags )
  42 import Class            ( mkClass, classBigSig, Class )
  43 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
  44 import MkId             ( mkDataCon, mkSuperDictSelId,
  45                           mkMethodSelId, mkDefaultMethodId
  46                         )
  47 import Id               ( Id, StrictnessMark(..),
  48                           getIdUnfolding, idType, idName
  49                         )
  50 import CoreUnfold       ( getUnfoldingTemplate )
  51 import IdInfo
  52 import Name             ( Name, isLocallyDefined, OccName, nameOccName,
  53                           NamedThing(..) )
  54 import Outputable
  55 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
  56                           mkSigmaTy, mkForAllTys, Type, ThetaType
  57                         )
  58 import TyVar            ( mkTyVarSet, tyVarKind, TyVar )
  59 import TyCon            ( mkDataTyCon )
  60 import Kind             ( mkBoxedTypeKind, mkArrowKind )
  61 import Unique           ( Unique, Uniquable(..) )
  62 import Util
  63 import Maybes           ( assocMaybe, maybeToBool, seqMaybe )
  64
  65
  66 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  67 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  68 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
  69                                                    noIdInfo)
  70 \end{code}
  71
  72
  73
  74 Dictionary handling
  75 ~~~~~~~~~~~~~~~~~~~
  76 Every class implicitly declares a new data type, corresponding to dictionaries
  77 of that class. So, for example:
  78
  79         class (D a) => C a where
  80           op1 :: a -> a
  81           op2 :: forall b. Ord b => a -> b -> b
  82
  83 would implicitly declare
  84
  85         data CDict a = CDict (D a)
  86                              (a -> a)
  87                              (forall b. Ord b => a -> b -> b)
  88
  89 (We could use a record decl, but that means changing more of the existing apparatus.
  90 One step at at time!)
  91
  92 For classes with just one superclass+method, we use a newtype decl instead:
  93
  94         class C a where
  95           op :: forallb. a -> b -> b
  96
  97 generates
  98
  99         newtype CDict a = CDict (forall b. a -> b -> b)
 100
 101 Now DictTy in Type is just a form of type synomym:
 102         DictTy c t = TyConTy CDict `AppTy` t
 103
 104 Death to "ExpandingDicts".
 105
 106
 107 \begin{code}
 108 tcClassDecl1 rec_env rec_inst_mapper
 109              (ClassDecl context class_name
 110                         tyvar_names class_sigs def_methods pragmas
 111                         tycon_name datacon_name src_loc)
 112   = tcAddSrcLoc src_loc $
 113     tcAddErrCtxt (classDeclCtxt class_name) $
 114
 115         -- CHECK ARITY 1 FOR HASKELL 1.4
 116     checkTc (opt_GlasgowExts || length tyvar_names == 1)
 117             (classArityErr class_name)          `thenTc_`
 118
 119         -- LOOK THINGS UP IN THE ENVIRONMENT
 120     tcLookupClass class_name                    `thenTc` \ (class_kinds, rec_class) ->
 121     mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names
 122                                                 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 123
 124         -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
 125     unifyKinds class_kinds tyvar_kinds  `thenTc_`
 126
 127         -- CHECK THE CONTEXT
 128     tcClassContext class_name rec_class rec_tyvars context pragmas
 129                                                 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 130
 131         -- CHECK THE CLASS SIGNATURES,
 132     mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs
 133                                                 `thenTc` \ sig_stuff ->
 134
 135         -- MAKE THE CLASS OBJECT ITSELF
 136     let
 137         (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
 138         rec_class_inst_env = rec_inst_mapper rec_class
 139         clas = mkClass (getName class_name) rec_tyvars
 140                        sc_theta sc_sel_ids op_sel_ids defm_ids
 141                        tycon
 142                        rec_class_inst_env
 143
 144         dict_component_tys = sc_tys ++ op_tys
 145         new_or_data = case dict_component_tys of
 146                         [_]   -> NewType
 147                         other -> DataType
 148
 149         dict_con_id = mkDataCon datacon_name
 150                            [NotMarkedStrict | _ <- dict_component_tys]
 151                            [{- No labelled fields -}]
 152                            rec_tyvars
 153                            [{-No context-}]
 154                            [{-No existential tyvars-}] [{-Or context-}]
 155                            dict_component_tys
 156                            tycon
 157
 158         tycon = mkDataTyCon tycon_name
 159                             (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars)
 160                             rec_tyvars
 161                             []                  -- No context
 162                             [dict_con_id]       -- Constructors
 163                             []                  -- No derivings
 164                             (Just clas)         -- Yes!  It's a dictionary
 165                             new_or_data
 166                             NonRecursive
 167     in
 168     returnTc clas
 169 \end{code}
 170
 171
 172 \begin{code}
 173 tcClassContext :: Name -> Class -> [TyVar]
 174                -> RenamedContext        -- class context
 175                -> RenamedClassPragmas   -- pragmas for superclasses
 176                -> TcM s (ThetaType,     -- the superclass context
 177                          [Type],        -- types of the superclass dictionaries
 178                          [Id])          -- superclass selector Ids
 179
 180 tcClassContext class_name rec_class rec_tyvars context pragmas
 181   =     -- Check the context.
 182         -- The renamer has already checked that the context mentions
 183         -- only the type variable of the class decl.
 184
 185         -- For std Haskell check that the context constrains only tyvars
 186     (if opt_GlasgowExts then
 187         returnTc []
 188      else
 189         mapTc check_constraint context
 190     )                                   `thenTc_`
 191
 192     tcContext context                   `thenTc` \ sc_theta ->
 193
 194     let
 195        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
 196     in
 197
 198         -- Make super-class selector ids
 199         -- We number them off, 1, 2, 3 etc so that we can construct
 200         -- names for the selectors.  Thus
 201         --      class (C a, C b) => D a b where ...
 202         -- gives superclass selectors
 203         --      D_sc1, D_sc2
 204         -- (We used to call them D_C, but now we can have two different
 205         --  superclasses both called C!)
 206     mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..])   `thenTc` \ sc_sel_ids ->
 207
 208         -- Done
 209     returnTc (sc_theta, sc_tys, sc_sel_ids)
 210
 211   where
 212     rec_tyvar_tys = mkTyVarTys rec_tyvars
 213
 214     mk_super_id ((super_class, tys), index)
 215         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 216           let
 217                 ty = mkForAllTys rec_tyvars $
 218                      mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
 219           in
 220           returnTc (mkSuperDictSelId uniq rec_class index ty)
 221
 222     check_constraint (c, tys) = checkTc (all is_tyvar tys)
 223                                         (superClassErr class_name (c, tys))
 224
 225     is_tyvar (MonoTyVar _) = True
 226     is_tyvar other         = False
 227
 228
 229 tcClassSig :: GlobalValueEnv            -- Knot tying only!
 230            -> Class                     -- ...ditto...
 231            -> [TyVar]                   -- The class type variable, used for error check only
 232            -> RenamedClassOpSig
 233            -> TcM s (Type,              -- Type of the method
 234                      Id,                -- selector id
 235                      Maybe Id)          -- default-method ids
 236
 237 tcClassSig rec_env rec_clas rec_clas_tyvars
 238            (ClassOpSig op_name maybe_dm_name
 239                        op_ty
 240                        src_loc)
 241   = tcAddSrcLoc src_loc $
 242
 243         -- Check the type signature.  NB that the envt *already has*
 244         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 245
 246     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 247     -- and that it is not constrained by theta
 248     tcHsType op_ty                              `thenTc` \ local_ty ->
 249     let
 250         global_ty   = mkSigmaTy rec_clas_tyvars
 251                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 252                                 local_ty
 253     in
 254
 255         -- Build the selector id and default method id
 256     let
 257         sel_id      = mkMethodSelId op_name rec_clas global_ty
 258         maybe_dm_id = case maybe_dm_name of
 259                            Nothing      -> Nothing
 260                            Just dm_name -> let
 261                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 262                                            in
 263                                            Just (tcAddImportedIdInfo rec_env dm_id)
 264     in
 265     returnTc (local_ty, sel_id, maybe_dm_id)
 266 \end{code}
 267
 268
 269 %************************************************************************
 270 %*                                                                      *
 271 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 272 %*                                                                      *
 273 %************************************************************************
 274
 275 The purpose of pass 2 is
 276 \begin{enumerate}
 277 \item
 278 to beat on the explicitly-provided default-method decls (if any),
 279 using them to produce a complete set of default-method decls.
 280 (Omitted ones elicit an error message.)
 281 \item
 282 to produce a definition for the selector function for each method
 283 and superclass dictionary.
 284 \end{enumerate}
 285
 286 Pass~2 only applies to locally-defined class declarations.
 287
 288 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 289 each local class decl.
 290
 291 \begin{code}
 292 tcClassDecls2 :: [RenamedHsDecl]
 293               -> NF_TcM s (LIE s, TcMonoBinds s)
 294
 295 tcClassDecls2 decls
 296   = foldr combine
 297           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 298           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 299   where
 300     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 301                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 302                       returnNF_Tc (lie1 `plusLIE` lie2,
 303                                    binds1 `AndMonoBinds` binds2)
 304 \end{code}
 305
 306 @tcClassDecl2@ is the business end of things.
 307
 308 \begin{code}
 309 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 310              -> NF_TcM s (LIE s, TcMonoBinds s)
 311
 312 tcClassDecl2 (ClassDecl context class_name
 313                         tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 314
 315   | not (isLocallyDefined class_name)
 316   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 317
 318   | otherwise   -- It is locally defined
 319   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 320     tcAddSrcLoc src_loc                                   $
 321
 322         -- Get the relevant class
 323     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 324     let
 325         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 326
 327         -- The selector binds are already in the selector Id's unfoldings
 328         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 329                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 330                       isLocallyDefined sel_id
 331                     ]
 332
 333         final_sel_binds = andMonoBinds sel_binds
 334     in
 335         -- Generate bindings for the default methods
 336     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 337
 338     returnTc (const_insts,
 339               final_sel_binds `AndMonoBinds` meth_binds)
 340 \end{code}
 341
 342 %************************************************************************
 343 %*                                                                      *
 344 \subsection[Default methods]{Default methods}
 345 %*                                                                      *
 346 %************************************************************************
 347
 348 The default methods for a class are each passed a dictionary for the
 349 class, so that they get access to the other methods at the same type.
 350 So, given the class decl
 351 \begin{verbatim}
 352 class Foo a where
 353         op1 :: a -> Bool
 354         op2 :: Ord b => a -> b -> b -> b
 355
 356         op1 x = True
 357         op2 x y z = if (op1 x) && (y < z) then y else z
 358 \end{verbatim}
 359 we get the default methods:
 360 \begin{verbatim}
 361 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 362 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 363
 364 ====================== OLD ==================
 365 \begin{verbatim}
 366 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 367 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 368                   if (op1 a dfoo x) && (< b dord y z) then y else z
 369 \end{verbatim}
 370 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 371 ====================== END OF OLD ===================
 372
 373 NEW:
 374 \begin{verbatim}
 375 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 376 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 377                   if (op1 a dfoo x) && (< b dord y z) then y else z
 378 \end{verbatim}
 379
 380
 381 When we come across an instance decl, we may need to use the default
 382 methods:
 383 \begin{verbatim}
 384 instance Foo Int where {}
 385 \end{verbatim}
 386 gives
 387 \begin{verbatim}
 388 const.Foo.Int.op1 :: Int -> Bool
 389 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 390
 391 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 392 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 393
 394 dfun.Foo.Int :: Foo Int
 395 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 396 \end{verbatim}
 397 Notice that, as with method selectors above, we assume that dictionary
 398 application is curried, so there's no need to mention the Ord dictionary
 399 in const.Foo.Int.op2 (or the type variable).
 400
 401 \begin{verbatim}
 402 instance Foo a => Foo [a] where {}
 403
 404 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 405 dfun.Foo.List
 406   = /\ a -> \ dfoo_a ->
 407     let rec
 408         op1 = defm.Foo.op1 [a] dfoo_list
 409         op2 = defm.Foo.op2 [a] dfoo_list
 410         dfoo_list = (op1, op2)
 411     in
 412         dfoo_list
 413 \end{verbatim}
 414
 415 \begin{code}
 416 tcDefaultMethodBinds
 417         :: Class
 418         -> RenamedMonoBinds
 419         -> TcM s (LIE s, TcMonoBinds s)
 420
 421 tcDefaultMethodBinds clas default_binds
 422   =     -- Construct suitable signatures
 423     tcInstSigTyVars tyvars              `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 424
 425         -- Typecheck the default bindings
 426     let
 427         tc_dm sel_id_w_dm@(_, Just dm_id)
 428           = tcMethodBind clas origin inst_tys clas_tyvars
 429                          default_binds [{-no prags-}] False
 430                          sel_id_w_dm            `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 431             returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
 432     in
 433     mapAndUnzip3Tc tc_dm sel_ids_w_dms          `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 434
 435         -- Check the context
 436     newDicts origin [(clas,inst_tys)]           `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 437     let
 438         avail_insts = this_dict
 439     in
 440     tcAddErrCtxt (classDeclCtxt clas) $
 441     mapNF_Tc zonkSigTyVar clas_tyvars           `thenNF_Tc` \ clas_tyvars' ->
 442     tcSimplifyAndCheck
 443         (ptext SLIT("class") <+> ppr clas)
 444         (mkTyVarSet clas_tyvars')
 445         avail_insts
 446         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 447
 448     let
 449         full_binds = AbsBinds
 450                         clas_tyvars'
 451                         [this_dict_id]
 452                         abs_bind_stuff
 453                         (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
 454     in
 455     returnTc (const_lie, full_binds)
 456
 457   where
 458     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 459
 460     sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
 461                         -- Just the ones for which there is an explicit
 462                         -- user default declaration
 463
 464     origin = ClassDeclOrigin
 465 \end{code}
 466
 467 @tcMethodBind@ is used to type-check both default-method and
 468 instance-decl method declarations.  We must type-check methods one at a
 469 time, because their signatures may have different contexts and
 470 tyvar sets.
 471
 472 \begin{code}
 473 tcMethodBind
 474         :: Class
 475         -> InstOrigin s
 476         -> [TcType s]           -- Instance types
 477         -> [TcTyVar s]          -- Free variables of those instance types
 478                                 --  they'll be signature tyvars, and we
 479                                 --  want to check that they don't bound
 480         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 481         -> [RenamedSig]         -- Pramgas (just for this one)
 482         -> Bool                 -- True <=> supply default decl if no explicit decl
 483                                 --              This is true for instance decls,
 484                                 --              false for class decls
 485         -> (Id, Maybe Id)       -- The method selector and default-method Id
 486         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 487
 488 tcMethodBind clas origin inst_tys inst_tyvars
 489              meth_binds prags supply_default_bind
 490              (sel_id, maybe_dm_id)
 491  | no_user_bind && not supply_default_bind
 492  = pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
 493
 494  | otherwise
 495  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 496
 497         -- Warn if no method binding, only if -fwarn-missing-methods
 498    warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
 499           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 500
 501    newMethod origin (RealId sel_id) inst_tys    `thenNF_Tc` \ meth@(_, TcId meth_id) ->
 502    tcInstSigTcType (idType meth_id)     `thenNF_Tc` \ (tyvars', rho_ty') ->
 503    let
 504      (theta', tau') = splitRhoTy rho_ty'
 505
 506      meth_name  = idName meth_id
 507      sig_info   = TySigInfo meth_name meth_id tyvars' theta' tau' loc
 508      meth_bind  = mk_meth_bind meth_name loc
 509      meth_prags = find_prags meth_name prags
 510    in
 511    tcExtendLocalValEnv [meth_name] [meth_id] (
 512         tcPragmaSigs meth_prags
 513    )                                            `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
 514
 515         -- Check that the signatures match
 516    tcExtendGlobalTyVars inst_tyvars (
 517      tcAddErrCtxt (methodCtxt sel_id)           $
 518      tcBindWithSigs NotTopLevel [meth_name] meth_bind [sig_info]
 519                     NonRecursive prag_info_fn
 520    )                                                    `thenTc` \ (binds, insts, _) ->
 521
 522         -- The prag_lie for a SPECIALISE pragma will mention the function
 523         -- itself, so we have to simplify them away right now lest they float
 524         -- outwards!
 525    bindInstsOfLocalFuns prag_lie [meth_id]      `thenTc` \ (prag_lie', prag_binds2) ->
 526
 527         -- Now check that the instance type variables
 528         -- (or, in the case of a class decl, the class tyvars)
 529         -- have not been unified with anything in the environment
 530    tcAddErrCtxt (monoCtxt sel_id) (
 531      tcAddErrCtxt (sigCtxt sel_id) $
 532      checkSigTyVars inst_tyvars (idType meth_id)
 533    )                                                    `thenTc_`
 534
 535    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 536              insts `plusLIE` prag_lie',
 537              meth)
 538  where
 539    sel_name = idName sel_id
 540
 541    maybe_user_bind = find meth_binds
 542
 543    no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 544    no_user_default = case maybe_dm_id     of {Nothing -> True; other -> False}
 545
 546    find EmptyMonoBinds                         = Nothing
 547    find (AndMonoBinds b1 b2)                   = find b1 `seqMaybe` find b2
 548    find b@(FunMonoBind op_name _ _ _)          = if op_name == sel_name then Just b else Nothing
 549    find b@(PatMonoBind (VarPatIn op_name) _ _) = if op_name == sel_name then Just b else Nothing
 550    find other = panic "Urk! Bad instance method binding"
 551
 552         -- The renamer just puts the selector ID as the binder in the method binding
 553         -- but we must use the method name; so we substitute it here.  Crude but simple.
 554    mk_meth_bind meth_name loc
 555      = case maybe_user_bind of
 556          Just (FunMonoBind _ fix matches loc)    -> FunMonoBind meth_name fix matches loc
 557          Just (PatMonoBind (VarPatIn _) rhs loc) -> PatMonoBind (VarPatIn meth_name) rhs loc
 558          Nothing                                 -> mk_default_bind meth_name loc
 559
 560         -- Find the prags for this method, and replace the
 561         -- selector name with the method name
 562    find_prags meth_name [] = []
 563    find_prags meth_name (SpecSig name ty spec loc : prags)
 564         | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
 565    find_prags meth_name (InlineSig name loc : prags)
 566         | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
 567    find_prags meth_name (NoInlineSig name loc : prags)
 568         | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags
 569    find_prags meth_name (prag:prags) = find_prags meth_name prags
 570
 571    mk_default_bind local_meth_name loc
 572       = PatMonoBind (VarPatIn local_meth_name)
 573                     (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
 574                     loc
 575
 576    default_expr loc
 577       = case maybe_dm_id of
 578           Just dm_id -> HsVar (getName dm_id)   -- There's a default method
 579           Nothing    -> error_expr loc          -- No default method
 580
 581    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 582                           (HsLit (HsString (_PK_ (error_msg loc))))
 583
 584    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 585 \end{code}
 586
 587 Contexts and errors
 588 ~~~~~~~~~~~~~~~~~~~
 589 \begin{code}
 590 classArityErr class_name
 591   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 592
 593 classDeclCtxt class_name
 594   = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
 595
 596 superClassErr class_name sc
 597   = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
 598     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 599
 600 methodCtxt sel_id
 601   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 602
 603 monoCtxt sel_id
 604   = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
 605          nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
 606     ]
 607
 608 badMethodErr bndr clas
 609   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 610           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 611
 612 omittedMethodWarn sel_id clas
 613   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 614          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 615 \end{code}