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