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