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