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