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 ( kcClassDecl, tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
  12                           InPat(..), HsBinds(..), GRHSs(..),
  13                           HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
  14                           unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
  15                           isClassDecl, isClassOpSig
  16                         )
  17 import HsPragmas        ( ClassPragmas(..) )
  18 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
  19 import RnHsSyn          ( RenamedTyClDecl, RenamedClassPragmas,
  20                           RenamedClassOpSig, RenamedMonoBinds,
  21                           RenamedContext, RenamedHsDecl, RenamedSig
  22                         )
  23 import TcHsSyn          ( TcMonoBinds )
  24
  25 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
  26 import TcEnv            ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
  27                           tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
  28                           tcExtendLocalValEnv
  29                         )
  30 import TcBinds          ( tcBindWithSigs, tcPragmaSigs )
  31 import TcUnify          ( unifyKinds )
  32 import TcMonad
  33 import TcMonoType       ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
  34                           tcContext, checkSigTyVars, sigCtxt, mkTcSig
  35                         )
  36 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  37 import TcType           ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
  38 import PrelVals         ( nO_METHOD_BINDING_ERROR_ID )
  39 import FieldLabel       ( firstFieldLabelTag )
  40 import Bag              ( unionManyBags )
  41 import Class            ( mkClass, classBigSig, Class )
  42 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
  43 import MkId             ( mkSuperDictSelId, mkDataConId,
  44                           mkMethodSelId, mkDefaultMethodId
  45                         )
  46 import DataCon          ( mkDataCon )
  47 import Id               ( Id,
  48                           getIdUnfolding, idType, idName
  49                         )
  50 import CoreUnfold       ( getUnfoldingTemplate )
  51 import IdInfo
  52 import Name             ( Name, isLocallyDefined, NamedThing(..) )
  53 import Outputable
  54 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
  55                           mkSigmaTy, mkForAllTys, Type, ThetaType,
  56                           boxedTypeKind, mkArrowKind
  57                         )
  58 import Var              ( tyVarKind, TyVar )
  59 import VarSet           ( mkVarSet )
  60 import TyCon            ( mkAlgTyCon )
  61 import Unique           ( Unique, Uniquable(..) )
  62 import Util
  63 import Maybes           ( seqMaybe )
  64 import FiniteMap        ( lookupWithDefaultFM )
  65
  66
  67 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  68 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  69 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
  70                                                    noIdInfo)
  71 \end{code}
  72
  73
  74
  75 Dictionary handling
  76 ~~~~~~~~~~~~~~~~~~~
  77 Every class implicitly declares a new data type, corresponding to dictionaries
  78 of that class. So, for example:
  79
  80         class (D a) => C a where
  81           op1 :: a -> a
  82           op2 :: forall b. Ord b => a -> b -> b
  83
  84 would implicitly declare
  85
  86         data CDict a = CDict (D a)
  87                              (a -> a)
  88                              (forall b. Ord b => a -> b -> b)
  89
  90 (We could use a record decl, but that means changing more of the existing apparatus.
  91 One step at at time!)
  92
  93 For classes with just one superclass+method, we use a newtype decl instead:
  94
  95         class C a where
  96           op :: forallb. a -> b -> b
  97
  98 generates
  99
 100         newtype CDict a = CDict (forall b. a -> b -> b)
 101
 102 Now DictTy in Type is just a form of type synomym:
 103         DictTy c t = TyConTy CDict `AppTy` t
 104
 105 Death to "ExpandingDicts".
 106
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 \subsection{Kind checking}
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 \begin{code}
 115 kcClassDecl (ClassDecl  context class_name
 116                         tyvar_names class_sigs def_methods pragmas
 117                         tycon_name datacon_name src_loc)
 118   =         -- CHECK ARITY 1 FOR HASKELL 1.4
 119     checkTc (opt_GlasgowExts || length tyvar_names == 1)
 120             (classArityErr class_name)          `thenTc_`
 121
 122         -- Get the (mutable) class kind
 123     tcLookupTy class_name                       `thenNF_Tc` \ (kind, _, _) ->
 124
 125         -- Make suitable tyvars and do kind checking
 126         -- The net effect is to mutate the class kind
 127     tcExtendTopTyVarScope kind tyvar_names      $ \ _ _ ->
 128     tcContext context                           `thenTc_`
 129     mapTc kc_sig the_class_sigs                 `thenTc_`
 130
 131     returnTc ()
 132   where
 133     the_class_sigs = filter isClassOpSig class_sigs
 134
 135     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
 136 \end{code}
 137
 138
 139 %************************************************************************
 140 %*                                                                      *
 141 \subsection{Type checking}
 142 %*                                                                      *
 143 %************************************************************************
 144
 145 \begin{code}
 146 tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
 147              (ClassDecl context class_name
 148                         tyvar_names class_sigs def_methods pragmas
 149                         tycon_name datacon_name src_loc)
 150   =     -- LOOK THINGS UP IN THE ENVIRONMENT
 151     tcLookupTy class_name                               `thenTc` \ (class_kind, _, AClass rec_class) ->
 152     tcExtendTopTyVarScope class_kind tyvar_names        $ \ tyvars _ ->
 153         -- The class kind is by now immutable
 154
 155         -- CHECK THE CONTEXT
 156 --  traceTc (text "tcClassCtxt" <+> ppr class_name)     `thenTc_`
 157     tcClassContext class_name rec_class tyvars context pragmas
 158                                                 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 159 --  traceTc (text "tcClassCtxt done" <+> ppr class_name)        `thenTc_`
 160
 161         -- CHECK THE CLASS SIGNATURES,
 162     mapTc (tcClassSig rec_env rec_class tyvars)
 163           (filter isClassOpSig class_sigs)
 164                                                 `thenTc` \ sig_stuff ->
 165
 166         -- MAKE THE CLASS OBJECT ITSELF
 167     let
 168         (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
 169         rec_class_inst_env = rec_inst_mapper rec_class
 170         clas = mkClass class_name tyvars
 171                        sc_theta sc_sel_ids op_sel_ids defm_ids
 172                        tycon
 173                        rec_class_inst_env
 174
 175         dict_component_tys = sc_tys ++ op_tys
 176         new_or_data = case dict_component_tys of
 177                         [_]   -> NewType
 178                         other -> DataType
 179
 180         dict_con = mkDataCon datacon_name
 181                            [NotMarkedStrict | _ <- dict_component_tys]
 182                            [{- No labelled fields -}]
 183                            tyvars
 184                            [{-No context-}]
 185                            [{-No existential tyvars-}] [{-Or context-}]
 186                            dict_component_tys
 187                            tycon dict_con_id
 188         dict_con_id = mkDataConId dict_con
 189
 190         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
 191                                                          ppr tycon_name)
 192                                       tycon_name
 193
 194         tycon = mkAlgTyCon tycon_name
 195                             class_kind
 196                             tyvars
 197                             []                  -- No context
 198                             argvrcs
 199                             [dict_con]          -- Constructors
 200                             []                  -- No derivings
 201                             (Just clas)         -- Yes!  It's a dictionary
 202                             new_or_data
 203                             NonRecursive
 204     in
 205     returnTc clas
 206 \end{code}
 207
 208
 209 \begin{code}
 210 tcClassContext :: Name -> Class -> [TyVar]
 211                -> RenamedContext        -- class context
 212                -> RenamedClassPragmas   -- pragmas for superclasses
 213                -> TcM s (ThetaType,     -- the superclass context
 214                          [Type],        -- types of the superclass dictionaries
 215                          [Id])          -- superclass selector Ids
 216
 217 tcClassContext class_name rec_class rec_tyvars context pragmas
 218   =     -- Check the context.
 219         -- The renamer has already checked that the context mentions
 220         -- only the type variable of the class decl.
 221
 222         -- For std Haskell check that the context constrains only tyvars
 223     (if opt_GlasgowExts then
 224         returnTc []
 225      else
 226         mapTc check_constraint context
 227     )                                   `thenTc_`
 228
 229     tcContext context                   `thenTc` \ sc_theta ->
 230
 231     let
 232        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
 233     in
 234
 235         -- Make super-class selector ids
 236         -- We number them off, 1, 2, 3 etc so that we can construct
 237         -- names for the selectors.  Thus
 238         --      class (C a, C b) => D a b where ...
 239         -- gives superclass selectors
 240         --      D_sc1, D_sc2
 241         -- (We used to call them D_C, but now we can have two different
 242         --  superclasses both called C!)
 243     mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..])   `thenTc` \ sc_sel_ids ->
 244
 245         -- Done
 246     returnTc (sc_theta, sc_tys, sc_sel_ids)
 247
 248   where
 249     rec_tyvar_tys = mkTyVarTys rec_tyvars
 250
 251     mk_super_id ((super_class, tys), index)
 252         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 253           let
 254                 ty = mkForAllTys rec_tyvars $
 255                      mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
 256           in
 257           returnTc (mkSuperDictSelId uniq rec_class index ty)
 258
 259     check_constraint (c, tys) = checkTc (all is_tyvar tys)
 260                                         (superClassErr class_name (c, tys))
 261
 262     is_tyvar (MonoTyVar _) = True
 263     is_tyvar other         = False
 264
 265
 266 tcClassSig :: ValueEnv          -- Knot tying only!
 267            -> Class                     -- ...ditto...
 268            -> [TyVar]                   -- The class type variable, used for error check only
 269            -> RenamedClassOpSig
 270            -> TcM s (Type,              -- Type of the method
 271                      Id,                -- selector id
 272                      Maybe Id)          -- default-method ids
 273
 274 tcClassSig rec_env rec_clas rec_clas_tyvars
 275            (ClassOpSig op_name maybe_dm_name
 276                        op_ty
 277                        src_loc)
 278   = tcAddSrcLoc src_loc $
 279
 280         -- Check the type signature.  NB that the envt *already has*
 281         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 282
 283     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 284     -- and that it is not constrained by theta
 285 --  traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
 286     tcHsTopType op_ty                           `thenTc` \ local_ty ->
 287     let
 288         global_ty   = mkSigmaTy rec_clas_tyvars
 289                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 290                                 local_ty
 291
 292         -- Build the selector id and default method id
 293         sel_id      = mkMethodSelId op_name rec_clas global_ty
 294         maybe_dm_id = case maybe_dm_name of
 295                            Nothing      -> Nothing
 296                            Just dm_name -> let
 297                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 298                                            in
 299                                            Just (tcAddImportedIdInfo rec_env dm_id)
 300     in
 301 --  traceTc (text "tcClassSig done" <+> ppr op_name)    `thenTc_`
 302     returnTc (local_ty, sel_id, maybe_dm_id)
 303 \end{code}
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 The purpose of pass 2 is
 313 \begin{enumerate}
 314 \item
 315 to beat on the explicitly-provided default-method decls (if any),
 316 using them to produce a complete set of default-method decls.
 317 (Omitted ones elicit an error message.)
 318 \item
 319 to produce a definition for the selector function for each method
 320 and superclass dictionary.
 321 \end{enumerate}
 322
 323 Pass~2 only applies to locally-defined class declarations.
 324
 325 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 326 each local class decl.
 327
 328 \begin{code}
 329 tcClassDecls2 :: [RenamedHsDecl]
 330               -> NF_TcM s (LIE, TcMonoBinds)
 331
 332 tcClassDecls2 decls
 333   = foldr combine
 334           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 335           [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
 336   where
 337     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 338                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 339                       returnNF_Tc (lie1 `plusLIE` lie2,
 340                                    binds1 `AndMonoBinds` binds2)
 341 \end{code}
 342
 343 @tcClassDecl2@ is the business end of things.
 344
 345 \begin{code}
 346 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 347              -> NF_TcM s (LIE, TcMonoBinds)
 348
 349 tcClassDecl2 (ClassDecl context class_name
 350                         tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 351
 352   | not (isLocallyDefined class_name)
 353   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 354
 355   | otherwise   -- It is locally defined
 356   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 357     tcAddSrcLoc src_loc                                   $
 358
 359         -- Get the relevant class
 360     tcLookupClass class_name                            `thenNF_Tc` \ clas ->
 361     let
 362         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 363
 364         -- The selector binds are already in the selector Id's unfoldings
 365 --      sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
 366 --                  | sel_id <- sc_sel_ids ++ op_sel_ids,
 367 --                    isLocallyDefined sel_id
 368 --                  ]
 369 --
 370 --      final_sel_binds = andMonoBindList sel_binds
 371     in
 372         -- Generate bindings for the default methods
 373     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 374
 375     returnTc (const_insts, meth_binds)
 376 --            final_sel_binds `AndMonoBinds` meth_binds)
 377 -- Leave 'em out for now.  They always get inlined anyway.  SLPJ June '98
 378 \end{code}
 379
 380 %************************************************************************
 381 %*                                                                      *
 382 \subsection[Default methods]{Default methods}
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 The default methods for a class are each passed a dictionary for the
 387 class, so that they get access to the other methods at the same type.
 388 So, given the class decl
 389 \begin{verbatim}
 390 class Foo a where
 391         op1 :: a -> Bool
 392         op2 :: Ord b => a -> b -> b -> b
 393
 394         op1 x = True
 395         op2 x y z = if (op1 x) && (y < z) then y else z
 396 \end{verbatim}
 397 we get the default methods:
 398 \begin{verbatim}
 399 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 400 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 401
 402 ====================== OLD ==================
 403 \begin{verbatim}
 404 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 405 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 406                   if (op1 a dfoo x) && (< b dord y z) then y else z
 407 \end{verbatim}
 408 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 409 ====================== END OF OLD ===================
 410
 411 NEW:
 412 \begin{verbatim}
 413 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 414 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 415                   if (op1 a dfoo x) && (< b dord y z) then y else z
 416 \end{verbatim}
 417
 418
 419 When we come across an instance decl, we may need to use the default
 420 methods:
 421 \begin{verbatim}
 422 instance Foo Int where {}
 423 \end{verbatim}
 424 gives
 425 \begin{verbatim}
 426 const.Foo.Int.op1 :: Int -> Bool
 427 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 428
 429 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 430 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 431
 432 dfun.Foo.Int :: Foo Int
 433 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 434 \end{verbatim}
 435 Notice that, as with method selectors above, we assume that dictionary
 436 application is curried, so there's no need to mention the Ord dictionary
 437 in const.Foo.Int.op2 (or the type variable).
 438
 439 \begin{verbatim}
 440 instance Foo a => Foo [a] where {}
 441
 442 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 443 dfun.Foo.List
 444   = /\ a -> \ dfoo_a ->
 445     let rec
 446         op1 = defm.Foo.op1 [a] dfoo_list
 447         op2 = defm.Foo.op2 [a] dfoo_list
 448         dfoo_list = (op1, op2)
 449     in
 450         dfoo_list
 451 \end{verbatim}
 452
 453 \begin{code}
 454 tcDefaultMethodBinds
 455         :: Class
 456         -> RenamedMonoBinds
 457         -> TcM s (LIE, TcMonoBinds)
 458
 459 tcDefaultMethodBinds clas default_binds
 460   =     -- Construct suitable signatures
 461     tcInstTyVars tyvars         `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 462
 463         -- Typecheck the default bindings
 464     let
 465         theta = [(clas,inst_tys)]
 466         tc_dm sel_id_w_dm@(_, Just dm_id)
 467           = tcMethodBind clas origin clas_tyvars inst_tys theta
 468                          default_binds [{-no prags-}] False
 469                          sel_id_w_dm            `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 470             returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id))
 471     in
 472     tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 473         mapAndUnzip3Tc tc_dm sel_ids_w_dms
 474     )                                           `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 475
 476
 477         -- Check the context
 478     newDicts origin theta                       `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 479     let
 480         avail_insts = this_dict
 481     in
 482     tcAddErrCtxt (defltMethCtxt clas) $
 483
 484         -- tcMethodBind has checked that the class_tyvars havn't
 485         -- been unified with each other or another type, but we must
 486         -- still zonk them before passing them to tcSimplifyAndCheck
 487     mapNF_Tc zonkTcTyVarBndr clas_tyvars        `thenNF_Tc` \ clas_tyvars' ->
 488
 489     tcSimplifyAndCheck
 490         (ptext SLIT("class") <+> ppr clas)
 491         (mkVarSet clas_tyvars')
 492         avail_insts
 493         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 494
 495     let
 496         full_binds = AbsBinds
 497                         clas_tyvars'
 498                         [this_dict_id]
 499                         abs_bind_stuff
 500                         (dict_binds `andMonoBinds` andMonoBindList defm_binds)
 501     in
 502     returnTc (const_lie, full_binds)
 503
 504   where
 505     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 506
 507     sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
 508                         -- Just the ones for which there is an explicit
 509                         -- user default declaration
 510
 511     origin = ClassDeclOrigin
 512 \end{code}
 513
 514 @tcMethodBind@ is used to type-check both default-method and
 515 instance-decl method declarations.  We must type-check methods one at a
 516 time, because their signatures may have different contexts and
 517 tyvar sets.
 518
 519 \begin{code}
 520 tcMethodBind
 521         :: Class
 522         -> InstOrigin
 523         -> [TcTyVar]            -- Instantiated type variables for the
 524                                 --  enclosing class/instance decl.
 525                                 --  They'll be signature tyvars, and we
 526                                 --  want to check that they don't get bound
 527         -> [TcType]             -- Instance types
 528         -> TcThetaType          -- Available theta; this could be used to check
 529                                 --  the method signature, but actually that's done by
 530                                 --  the caller;  here, it's just used for the error message
 531         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 532         -> [RenamedSig]         -- Pramgas (just for this one)
 533         -> Bool                 -- True <=> supply default decl if no explicit decl
 534                                 --              This is true for instance decls,
 535                                 --              false for class decls
 536         -> (Id, Maybe Id)       -- The method selector and default-method Id
 537         -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
 538
 539 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 540              meth_binds prags supply_default_bind
 541              (sel_id, maybe_dm_id)
 542  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 543
 544    newMethod origin sel_id inst_tys     `thenNF_Tc` \ meth@(_, meth_id) ->
 545    mkTcSig meth_id loc                  `thenNF_Tc` \ sig_info ->
 546
 547    let
 548      meth_name       = idName meth_id
 549      maybe_user_bind = find_bind meth_name meth_binds
 550
 551      no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 552      no_user_default = case maybe_dm_id     of {Nothing -> True; other -> False}
 553
 554      meth_bind = case maybe_user_bind of
 555                         Just bind -> bind
 556                         Nothing   -> mk_default_bind meth_name loc
 557
 558      meth_prags = find_prags meth_name prags
 559    in
 560
 561         -- Warn if no method binding, only if -fwarn-missing-methods
 562    if no_user_bind && not supply_default_bind then
 563         pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
 564    else
 565    warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
 566           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 567
 568         -- Check the pragmas
 569    tcExtendLocalValEnv [(meth_name, meth_id)] (
 570         tcPragmaSigs meth_prags
 571    )                                            `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
 572
 573         -- Check the bindings; first add inst_tyvars to the envt
 574         -- so that we don't quantify over them in nested places
 575         -- The *caller* put the class/inst decl tyvars into the envt
 576    tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
 577      tcAddErrCtxt (methodCtxt sel_id)           $
 578      tcBindWithSigs NotTopLevel meth_bind [sig_info]
 579                     NonRecursive prag_info_fn
 580    )                                            `thenTc` \ (binds, insts, _) ->
 581
 582
 583         -- The prag_lie for a SPECIALISE pragma will mention the function
 584         -- itself, so we have to simplify them away right now lest they float
 585         -- outwards!
 586    bindInstsOfLocalFuns prag_lie [meth_id]      `thenTc` \ (prag_lie', prag_binds2) ->
 587
 588
 589         -- Now check that the instance type variables
 590         -- (or, in the case of a class decl, the class tyvars)
 591         -- have not been unified with anything in the environment
 592    tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id)))  $
 593    checkSigTyVars inst_tyvars                                           `thenTc_`
 594
 595    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 596              insts `plusLIE` prag_lie',
 597              meth)
 598  where
 599    sig_msg ty = sep [ptext SLIT("When checking the expected type for"),
 600                     nest 4 (ppr sel_name <+> dcolon <+> ppr ty)]
 601
 602    sel_name = idName sel_id
 603
 604         -- The renamer just puts the selector ID as the binder in the method binding
 605         -- but we must use the method name; so we substitute it here.  Crude but simple.
 606    find_bind meth_name (FunMonoBind op_name fix matches loc)
 607         | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
 608    find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
 609         | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
 610    find_bind meth_name (AndMonoBinds b1 b2)
 611                               = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
 612    find_bind meth_name other  = Nothing -- Default case
 613
 614
 615         -- Find the prags for this method, and replace the
 616         -- selector name with the method name
 617    find_prags meth_name [] = []
 618    find_prags meth_name (SpecSig name ty spec loc : prags)
 619         | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
 620    find_prags meth_name (InlineSig name loc : prags)
 621         | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
 622    find_prags meth_name (NoInlineSig name loc : prags)
 623         | name == sel_name = NoInlineSig meth_name loc : find_prags meth_name prags
 624    find_prags meth_name (prag:prags) = find_prags meth_name prags
 625
 626    mk_default_bind local_meth_name loc
 627       = PatMonoBind (VarPatIn local_meth_name)
 628                     (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
 629                     loc
 630
 631    default_expr loc
 632       = case maybe_dm_id of
 633           Just dm_id -> HsVar (getName dm_id)   -- There's a default method
 634           Nothing    -> error_expr loc          -- No default method
 635
 636    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 637                           (HsLit (HsString (_PK_ (error_msg loc))))
 638
 639    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 640 \end{code}
 641
 642 Contexts and errors
 643 ~~~~~~~~~~~~~~~~~~~
 644 \begin{code}
 645 classArityErr class_name
 646   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 647
 648 superClassErr class_name sc
 649   = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
 650     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 651
 652 defltMethCtxt class_name
 653   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
 654
 655 methodCtxt sel_id
 656   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 657
 658 badMethodErr bndr clas
 659   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 660           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 661
 662 omittedMethodWarn sel_id clas
 663   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 664          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 665 \end{code}