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