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(..),
  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 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 :: 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 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     tcContext context                   `thenTc` \ sc_theta ->
 185     let
 186        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
 187     in
 188
 189         -- Make super-class selector ids
 190         -- We number them off, 1, 2, 3 etc so that we can construct
 191         -- names for the selectors.  Thus
 192         --      class (C a, C b) => D a b where ...
 193         -- gives superclass selectors
 194         --      D_sc1, D_sc2
 195         -- (We used to call them D_C, but now we can have two different
 196         --  superclasses both called C!)
 197     mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..])   `thenTc` \ sc_sel_ids ->
 198
 199         -- Done
 200     returnTc (sc_theta, sc_tys, sc_sel_ids)
 201
 202   where
 203     rec_tyvar_tys = mkTyVarTys rec_tyvars
 204
 205     mk_super_id ((super_class, tys), index)
 206         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 207           let
 208                 ty = mkForAllTys rec_tyvars $
 209                      mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
 210           in
 211           returnTc (mkSuperDictSelId uniq rec_class index ty)
 212
 213
 214 tcClassSig :: GlobalValueEnv            -- Knot tying only!
 215            -> Class                     -- ...ditto...
 216            -> [TyVar]                   -- The class type variable, used for error check only
 217            -> RenamedClassOpSig
 218            -> TcM s (Type,              -- Type of the method
 219                      Id,                -- selector id
 220                      Maybe Id)          -- default-method ids
 221
 222 tcClassSig rec_env rec_clas rec_clas_tyvars
 223            (ClassOpSig op_name maybe_dm_name
 224                        op_ty
 225                        src_loc)
 226   = tcAddSrcLoc src_loc $
 227
 228         -- Check the type signature.  NB that the envt *already has*
 229         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 230
 231     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 232     -- and that it is not constrained by theta
 233     tcHsType op_ty                              `thenTc` \ local_ty ->
 234     let
 235         global_ty   = mkSigmaTy rec_clas_tyvars
 236                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 237                                 local_ty
 238     in
 239
 240         -- Build the selector id and default method id
 241     let
 242         sel_id      = mkMethodSelId op_name rec_clas global_ty
 243         maybe_dm_id = case maybe_dm_name of
 244                            Nothing      -> Nothing
 245                            Just dm_name -> let
 246                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 247                                            in
 248                                            Just (tcAddImportedIdInfo rec_env dm_id)
 249     in
 250     returnTc (local_ty, sel_id, maybe_dm_id)
 251 \end{code}
 252
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 The purpose of pass 2 is
 261 \begin{enumerate}
 262 \item
 263 to beat on the explicitly-provided default-method decls (if any),
 264 using them to produce a complete set of default-method decls.
 265 (Omitted ones elicit an error message.)
 266 \item
 267 to produce a definition for the selector function for each method
 268 and superclass dictionary.
 269 \end{enumerate}
 270
 271 Pass~2 only applies to locally-defined class declarations.
 272
 273 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 274 each local class decl.
 275
 276 \begin{code}
 277 tcClassDecls2 :: [RenamedHsDecl]
 278               -> NF_TcM s (LIE s, TcMonoBinds s)
 279
 280 tcClassDecls2 decls
 281   = foldr combine
 282           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 283           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 284   where
 285     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 286                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 287                       returnNF_Tc (lie1 `plusLIE` lie2,
 288                                    binds1 `AndMonoBinds` binds2)
 289 \end{code}
 290
 291 @tcClassDecl2@ is the business end of things.
 292
 293 \begin{code}
 294 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 295              -> NF_TcM s (LIE s, TcMonoBinds s)
 296
 297 tcClassDecl2 (ClassDecl context class_name
 298                         tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 299
 300   | not (isLocallyDefined class_name)
 301   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 302
 303   | otherwise   -- It is locally defined
 304   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 305     tcAddSrcLoc src_loc                                   $
 306
 307         -- Get the relevant class
 308     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 309     let
 310         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 311
 312         -- The selector binds are already in the selector Id's unfoldings
 313         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 314                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 315                       isLocallyDefined sel_id
 316                     ]
 317
 318         final_sel_binds = andMonoBinds sel_binds
 319     in
 320         -- Generate bindings for the default methods
 321     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 322
 323     returnTc (const_insts,
 324               final_sel_binds `AndMonoBinds` meth_binds)
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection[Default methods]{Default methods}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 The default methods for a class are each passed a dictionary for the
 334 class, so that they get access to the other methods at the same type.
 335 So, given the class decl
 336 \begin{verbatim}
 337 class Foo a where
 338         op1 :: a -> Bool
 339         op2 :: Ord b => a -> b -> b -> b
 340
 341         op1 x = True
 342         op2 x y z = if (op1 x) && (y < z) then y else z
 343 \end{verbatim}
 344 we get the default methods:
 345 \begin{verbatim}
 346 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 347 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 348
 349 ====================== OLD ==================
 350 \begin{verbatim}
 351 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 352 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 353                   if (op1 a dfoo x) && (< b dord y z) then y else z
 354 \end{verbatim}
 355 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 356 ====================== END OF OLD ===================
 357
 358 NEW:
 359 \begin{verbatim}
 360 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 361 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 362                   if (op1 a dfoo x) && (< b dord y z) then y else z
 363 \end{verbatim}
 364
 365
 366 When we come across an instance decl, we may need to use the default
 367 methods:
 368 \begin{verbatim}
 369 instance Foo Int where {}
 370 \end{verbatim}
 371 gives
 372 \begin{verbatim}
 373 const.Foo.Int.op1 :: Int -> Bool
 374 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 375
 376 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 377 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 378
 379 dfun.Foo.Int :: Foo Int
 380 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 381 \end{verbatim}
 382 Notice that, as with method selectors above, we assume that dictionary
 383 application is curried, so there's no need to mention the Ord dictionary
 384 in const.Foo.Int.op2 (or the type variable).
 385
 386 \begin{verbatim}
 387 instance Foo a => Foo [a] where {}
 388
 389 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 390 dfun.Foo.List
 391   = /\ a -> \ dfoo_a ->
 392     let rec
 393         op1 = defm.Foo.op1 [a] dfoo_list
 394         op2 = defm.Foo.op2 [a] dfoo_list
 395         dfoo_list = (op1, op2)
 396     in
 397         dfoo_list
 398 \end{verbatim}
 399
 400 \begin{code}
 401 tcDefaultMethodBinds
 402         :: Class
 403         -> RenamedMonoBinds
 404         -> TcM s (LIE s, TcMonoBinds s)
 405
 406 tcDefaultMethodBinds clas default_binds
 407   =     -- Construct suitable signatures
 408     tcInstSigTyVars tyvars              `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 409
 410         -- Typecheck the default bindings
 411     let
 412         tc_dm sel_id_w_dm@(_, Just dm_id)
 413           = tcMethodBind clas origin inst_tys clas_tyvars
 414                          default_binds [{-no prags-}] False
 415                          sel_id_w_dm            `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 416             returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
 417     in
 418     mapAndUnzip3Tc tc_dm sel_ids_w_dms          `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 419
 420         -- Check the context
 421     newDicts origin [(clas,inst_tys)]           `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 422     let
 423         avail_insts = this_dict
 424     in
 425     tcAddErrCtxt (classDeclCtxt clas) $
 426     mapNF_Tc zonkSigTyVar clas_tyvars           `thenNF_Tc` \ clas_tyvars' ->
 427     tcSimplifyAndCheck
 428         (ptext SLIT("class") <+> ppr clas)
 429         (mkTyVarSet clas_tyvars')
 430         avail_insts
 431         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 432
 433     let
 434         full_binds = AbsBinds
 435                         clas_tyvars'
 436                         [this_dict_id]
 437                         abs_bind_stuff
 438                         (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
 439     in
 440     returnTc (const_lie, full_binds)
 441
 442   where
 443     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 444
 445     sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
 446                         -- Just the ones for which there is an explicit
 447                         -- user default declaration
 448
 449     origin = ClassDeclOrigin
 450 \end{code}
 451
 452 @tcMethodBind@ is used to type-check both default-method and
 453 instance-decl method declarations.  We must type-check methods one at a
 454 time, because their signatures may have different contexts and
 455 tyvar sets.
 456
 457 \begin{code}
 458 tcMethodBind
 459         :: Class
 460         -> InstOrigin s
 461         -> [TcType s]           -- Instance types
 462         -> [TcTyVar s]          -- Free variables of those instance types
 463                                 --  they'll be signature tyvars, and we
 464                                 --  want to check that they don't bound
 465         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 466         -> [RenamedSig]         -- Pramgas (just for this one)
 467         -> Bool                 -- True <=> supply default decl if no explicit decl
 468                                 --              This is true for instance decls,
 469                                 --              false for class decls
 470         -> (Id, Maybe Id)       -- The method selector and default-method Id
 471         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 472
 473 tcMethodBind clas origin inst_tys inst_tyvars
 474              meth_binds prags supply_default_bind
 475              (sel_id, maybe_dm_id)
 476  | no_user_bind && not supply_default_bind
 477  = pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
 478
 479  | otherwise
 480  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 481
 482         -- Warn if no method binding, only if -fwarn-missing-methods
 483    warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
 484           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 485
 486    newMethod origin (RealId sel_id) inst_tys    `thenNF_Tc` \ meth@(_, TcId meth_id) ->
 487    tcInstSigTcType (idType meth_id)     `thenNF_Tc` \ (tyvars', rho_ty') ->
 488    let
 489      (theta', tau') = splitRhoTy rho_ty'
 490
 491      meth_name  = idName meth_id
 492      sig_info   = TySigInfo meth_name meth_id tyvars' theta' tau' loc
 493      meth_bind  = mk_meth_bind meth_name loc
 494      meth_prags = find_prags meth_name prags
 495    in
 496    tcExtendLocalValEnv [meth_name] [meth_id] (
 497         tcPragmaSigs meth_prags
 498    )                                            `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
 499
 500         -- Check that the signatures match
 501    tcExtendGlobalTyVars inst_tyvars (
 502      tcAddErrCtxt (methodCtxt sel_id)           $
 503      tcBindWithSigs NotTopLevel [meth_name] meth_bind [sig_info]
 504                     NonRecursive prag_info_fn
 505    )                                                    `thenTc` \ (binds, insts, _) ->
 506
 507         -- The prag_lie for a SPECIALISE pragma will mention the function
 508         -- itself, so we have to simplify them away right now lest they float
 509         -- outwards!
 510    bindInstsOfLocalFuns prag_lie [meth_id]      `thenTc` \ (prag_lie', prag_binds2) ->
 511
 512         -- Now check that the instance type variables
 513         -- (or, in the case of a class decl, the class tyvars)
 514         -- have not been unified with anything in the environment
 515    tcAddErrCtxt (monoCtxt sel_id) (
 516      tcAddErrCtxt (sigCtxt sel_id) $
 517      checkSigTyVars inst_tyvars (idType meth_id)
 518    )                                                    `thenTc_`
 519
 520    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 521              insts `plusLIE` prag_lie',
 522              meth)
 523  where
 524    sel_name = idName sel_id
 525
 526    maybe_user_bind = find meth_binds
 527
 528    no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 529    no_user_default = case maybe_dm_id     of {Nothing -> True; other -> False}
 530
 531    find EmptyMonoBinds                         = Nothing
 532    find (AndMonoBinds b1 b2)                   = find b1 `seqMaybe` find b2
 533    find b@(FunMonoBind op_name _ _ _)          = if op_name == sel_name then Just b else Nothing
 534    find b@(PatMonoBind (VarPatIn op_name) _ _) = if op_name == sel_name then Just b else Nothing
 535    find other = panic "Urk! Bad instance method binding"
 536
 537         -- The renamer just puts the selector ID as the binder in the method binding
 538         -- but we must use the method name; so we substitute it here.  Crude but simple.
 539    mk_meth_bind meth_name loc
 540      = case maybe_user_bind of
 541          Just (FunMonoBind _ fix matches loc)    -> FunMonoBind meth_name fix matches loc
 542          Just (PatMonoBind (VarPatIn _) rhs loc) -> PatMonoBind (VarPatIn meth_name) rhs loc
 543          Nothing                                 -> mk_default_bind meth_name loc
 544
 545         -- Find the prags for this method, and replace the
 546         -- selector name with the method name
 547    find_prags meth_name [] = []
 548    find_prags meth_name (SpecSig name ty spec loc : prags)
 549         | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
 550    find_prags meth_name (InlineSig name loc : prags)
 551         | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
 552    find_prags meth_name (prag:prags) = find_prags meth_name prags
 553
 554    mk_default_bind local_meth_name loc
 555       = PatMonoBind (VarPatIn local_meth_name)
 556                     (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
 557                     loc
 558
 559    default_expr loc
 560       = case maybe_dm_id of
 561           Just dm_id -> HsVar (getName dm_id)   -- There's a default method
 562           Nothing    -> error_expr loc          -- No default method
 563
 564    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 565                           (HsLit (HsString (_PK_ (error_msg loc))))
 566
 567    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 568 \end{code}
 569
 570 Contexts and errors
 571 ~~~~~~~~~~~~~~~~~~~
 572 \begin{code}
 573 classArityErr class_name
 574   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 575
 576 classDeclCtxt class_name
 577   = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
 578
 579 methodCtxt sel_id
 580   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 581
 582 monoCtxt sel_id
 583   = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
 584          nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
 585     ]
 586
 587 badMethodErr bndr clas
 588   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 589           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 590
 591 omittedMethodWarn sel_id clas
 592   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 593          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 594 \end{code}