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