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