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