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, isPragSig, 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       ( unfoldingTemplate )
  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         dict_con_id = mkDataConId dict_con
 183
 184         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
 185                                                          ppr tycon_name)
 186                                       tycon_name
 187
 188         tycon = mkAlgTyCon tycon_name
 189                             class_kind
 190                             tyvars
 191                             []                  -- No context
 192                             argvrcs
 193                             [dict_con]          -- Constructors
 194                             []                  -- No derivings
 195                             (Just clas)         -- Yes!  It's a dictionary
 196                             new_or_data
 197                             NonRecursive
 198     in
 199     returnTc clas
 200 \end{code}
 201
 202
 203 \begin{code}
 204 tcClassContext :: Name -> Class -> [TyVar]
 205                -> RenamedContext        -- class context
 206                -> [Name]                -- Names for superclass selectors
 207                -> TcM s (ThetaType,     -- the superclass context
 208                          [Type],        -- types of the superclass dictionaries
 209                          [Id])          -- superclass selector Ids
 210
 211 tcClassContext class_name rec_class rec_tyvars context sc_sel_names
 212   =     -- Check the context.
 213         -- The renamer has already checked that the context mentions
 214         -- only the type variable of the class decl.
 215
 216         -- For std Haskell check that the context constrains only tyvars
 217     (if opt_GlasgowExts then
 218         returnTc []
 219      else
 220         mapTc check_constraint context
 221     )                                   `thenTc_`
 222
 223     tcContext context                   `thenTc` \ sc_theta ->
 224
 225     let
 226        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
 227        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
 228     in
 229         -- Done
 230     returnTc (sc_theta, sc_tys, sc_sel_ids)
 231
 232   where
 233     rec_tyvar_tys = mkTyVarTys rec_tyvars
 234
 235     mk_super_id name dict_ty
 236         = mkDictSelId name rec_class ty
 237         where
 238           ty = mkForAllTys rec_tyvars $
 239                mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
 240
 241     check_constraint (c, tys) = checkTc (all is_tyvar tys)
 242                                         (superClassErr class_name (c, tys))
 243
 244     is_tyvar (MonoTyVar _) = True
 245     is_tyvar other         = False
 246
 247
 248 tcClassSig :: ValueEnv          -- Knot tying only!
 249            -> Class                     -- ...ditto...
 250            -> [TyVar]                   -- The class type variable, used for error check only
 251            -> RenamedClassOpSig
 252            -> TcM s (Type,              -- Type of the method
 253                      Id,                -- selector id
 254                      Maybe Id)          -- default-method ids
 255
 256 tcClassSig rec_env rec_clas rec_clas_tyvars
 257            (ClassOpSig op_name maybe_dm_name
 258                        op_ty
 259                        src_loc)
 260   = tcAddSrcLoc src_loc $
 261
 262         -- Check the type signature.  NB that the envt *already has*
 263         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 264
 265     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 266     -- and that it is not constrained by theta
 267 --  traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
 268     tcHsTopType op_ty                           `thenTc` \ local_ty ->
 269     let
 270         global_ty   = mkSigmaTy rec_clas_tyvars
 271                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 272                                 local_ty
 273
 274         -- Build the selector id and default method id
 275         sel_id      = mkDictSelId op_name rec_clas global_ty
 276         maybe_dm_id = case maybe_dm_name of
 277                            Nothing      -> Nothing
 278                            Just dm_name -> let
 279                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 280                                            in
 281                                            Just (tcAddImportedIdInfo rec_env dm_id)
 282     in
 283 --  traceTc (text "tcClassSig done" <+> ppr op_name)    `thenTc_`
 284     returnTc (local_ty, sel_id, maybe_dm_id)
 285 \end{code}
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 The purpose of pass 2 is
 295 \begin{enumerate}
 296 \item
 297 to beat on the explicitly-provided default-method decls (if any),
 298 using them to produce a complete set of default-method decls.
 299 (Omitted ones elicit an error message.)
 300 \item
 301 to produce a definition for the selector function for each method
 302 and superclass dictionary.
 303 \end{enumerate}
 304
 305 Pass~2 only applies to locally-defined class declarations.
 306
 307 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 308 each local class decl.
 309
 310 \begin{code}
 311 tcClassDecls2 :: [RenamedHsDecl]
 312               -> NF_TcM s (LIE, TcMonoBinds)
 313
 314 tcClassDecls2 decls
 315   = foldr combine
 316           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 317           [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
 318   where
 319     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 320                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 321                       returnNF_Tc (lie1 `plusLIE` lie2,
 322                                    binds1 `AndMonoBinds` binds2)
 323 \end{code}
 324
 325 @tcClassDecl2@ is the business end of things.
 326
 327 \begin{code}
 328 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 329              -> NF_TcM s (LIE, TcMonoBinds)
 330
 331 tcClassDecl2 (ClassDecl context class_name
 332                         tyvar_names class_sigs default_binds pragmas _ _ _ src_loc)
 333
 334   | not (isLocallyDefined class_name)
 335   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 336
 337   | otherwise   -- It is locally defined
 338   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 339     tcAddSrcLoc src_loc                                   $
 340
 341         -- Get the relevant class
 342     tcLookupClass class_name                            `thenNF_Tc` \ clas ->
 343     let
 344         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 345
 346         -- The selector binds are already in the selector Id's unfoldings
 347         sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id))
 348                     | sel_id <- sc_sel_ids ++ op_sel_ids
 349                     ]
 350     in
 351         -- Generate bindings for the default methods
 352     tcDefaultMethodBinds clas default_binds class_sigs          `thenTc` \ (const_insts, meth_binds) ->
 353
 354     returnTc (const_insts,
 355               meth_binds `AndMonoBinds` andMonoBindList sel_binds)
 356 \end{code}
 357
 358 %************************************************************************
 359 %*                                                                      *
 360 \subsection[Default methods]{Default methods}
 361 %*                                                                      *
 362 %************************************************************************
 363
 364 The default methods for a class are each passed a dictionary for the
 365 class, so that they get access to the other methods at the same type.
 366 So, given the class decl
 367 \begin{verbatim}
 368 class Foo a where
 369         op1 :: a -> Bool
 370         op2 :: Ord b => a -> b -> b -> b
 371
 372         op1 x = True
 373         op2 x y z = if (op1 x) && (y < z) then y else z
 374 \end{verbatim}
 375 we get the default methods:
 376 \begin{verbatim}
 377 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 378 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 379
 380 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 381 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 382                   if (op1 a dfoo x) && (< b dord y z) then y else z
 383 \end{verbatim}
 384
 385 When we come across an instance decl, we may need to use the default
 386 methods:
 387 \begin{verbatim}
 388 instance Foo Int where {}
 389 \end{verbatim}
 390 gives
 391 \begin{verbatim}
 392 const.Foo.Int.op1 :: Int -> Bool
 393 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 394
 395 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 396 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 397
 398 dfun.Foo.Int :: Foo Int
 399 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 400 \end{verbatim}
 401 Notice that, as with method selectors above, we assume that dictionary
 402 application is curried, so there's no need to mention the Ord dictionary
 403 in const.Foo.Int.op2 (or the type variable).
 404
 405 \begin{verbatim}
 406 instance Foo a => Foo [a] where {}
 407
 408 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 409 dfun.Foo.List
 410   = /\ a -> \ dfoo_a ->
 411     let rec
 412         op1 = defm.Foo.op1 [a] dfoo_list
 413         op2 = defm.Foo.op2 [a] dfoo_list
 414         dfoo_list = (op1, op2)
 415     in
 416         dfoo_list
 417 \end{verbatim}
 418
 419 \begin{code}
 420 tcDefaultMethodBinds
 421         :: Class
 422         -> RenamedMonoBinds
 423         -> [RenamedSig]
 424         -> TcM s (LIE, TcMonoBinds)
 425
 426 tcDefaultMethodBinds clas default_binds sigs
 427   =     -- Check that the default bindings come from this class
 428     checkFromThisClass clas op_sel_ids default_binds    `thenNF_Tc_`
 429
 430         -- Do each default method separately
 431     mapAndUnzipTc tc_dm sel_ids_w_dms                   `thenTc` \ (defm_binds, const_lies) ->
 432
 433     returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
 434   where
 435     prags = filter isPragSig sigs
 436
 437     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 438
 439     sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
 440                         -- Just the ones for which there is an explicit
 441                         -- user default declaration
 442
 443     origin = ClassDeclOrigin
 444
 445     -- We make a separate binding for each default method.
 446     -- At one time I used a single AbsBinds for all of them, thus
 447     --  AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 448     -- But that desugars into
 449     --  ds = \d -> (..., ..., ...)
 450     --  dm1 = \d -> case ds d of (a,b,c) -> a
 451     -- And since ds is big, it doesn't get inlined, so we don't get good
 452     -- default methods.  Better to make separate AbsBinds for each
 453
 454     tc_dm sel_id_w_dm@(_, Just dm_id)
 455       = tcInstTyVars tyvars             `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
 456         let
 457             theta = [(clas,inst_tys)]
 458         in
 459         newDicts origin theta                   `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 460         let
 461             avail_insts = this_dict
 462         in
 463         tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 464             tcMethodBind clas origin clas_tyvars inst_tys theta
 465                          default_binds prags False
 466                          sel_id_w_dm
 467         )                                       `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
 468
 469         tcAddErrCtxt (defltMethCtxt clas) $
 470
 471             -- tcMethodBind has checked that the class_tyvars havn't
 472             -- been unified with each other or another type, but we must
 473             -- still zonk them before passing them to tcSimplifyAndCheck
 474         mapNF_Tc zonkTcTyVarBndr clas_tyvars    `thenNF_Tc` \ clas_tyvars' ->
 475
 476             -- Check the context
 477         tcSimplifyAndCheck
 478             (ptext SLIT("class") <+> ppr clas)
 479             (mkVarSet clas_tyvars')
 480             avail_insts
 481             insts_needed                        `thenTc` \ (const_lie, dict_binds) ->
 482
 483         let
 484             full_bind = AbsBinds
 485                             clas_tyvars'
 486                             [this_dict_id]
 487                             [(clas_tyvars', dm_id, local_dm_id)]
 488                             emptyNameSet        -- No inlines (yet)
 489                             (dict_binds `andMonoBinds` defm_bind)
 490         in
 491         returnTc (full_bind, const_lie)
 492 \end{code}
 493
 494 \begin{code}
 495 checkFromThisClass :: Class -> [Id] -> RenamedMonoBinds -> NF_TcM s ()
 496 checkFromThisClass clas op_sel_ids mono_binds
 497   = mapNF_Tc check_from_this_class bndrs        `thenNF_Tc_`
 498     returnNF_Tc ()
 499   where
 500     check_from_this_class (bndr, loc)
 501           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 502           | otherwise                         = tcAddSrcLoc loc $
 503                                                 addErrTc (badMethodErr bndr clas)
 504     sel_names = map getOccName op_sel_ids
 505     bndrs = bagToList (collectMonoBinders mono_binds)
 506 \end{code}
 507
 508
 509 @tcMethodBind@ is used to type-check both default-method and
 510 instance-decl method declarations.  We must type-check methods one at a
 511 time, because their signatures may have different contexts and
 512 tyvar sets.
 513
 514 \begin{code}
 515 tcMethodBind
 516         :: Class
 517         -> InstOrigin
 518         -> [TcTyVar]            -- Instantiated type variables for the
 519                                 --  enclosing class/instance decl.
 520                                 --  They'll be signature tyvars, and we
 521                                 --  want to check that they don't get bound
 522         -> [TcType]             -- Instance types
 523         -> TcThetaType          -- Available theta; this could be used to check
 524                                 --  the method signature, but actually that's done by
 525                                 --  the caller;  here, it's just used for the error message
 526         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 527         -> [RenamedSig]         -- Pramgas (just for this one)
 528         -> Bool                 -- True <=> supply default decl if no explicit decl
 529                                 --              This is true for instance decls,
 530                                 --              false for class decls
 531         -> (Id, Maybe Id)       -- The method selector and default-method Id
 532         -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
 533
 534 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 535              meth_binds prags supply_default_bind
 536              (sel_id, maybe_dm_id)
 537  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 538
 539    newMethod origin sel_id inst_tys     `thenNF_Tc` \ meth@(_, meth_id) ->
 540    mkTcSig meth_id loc                  `thenNF_Tc` \ sig_info ->
 541
 542    let
 543      meth_name       = idName meth_id
 544      maybe_user_bind = find_bind meth_name meth_binds
 545
 546      no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 547      no_user_default = case maybe_dm_id     of {Nothing -> True; other -> False}
 548
 549      meth_bind = case maybe_user_bind of
 550                         Just bind -> bind
 551                         Nothing   -> mk_default_bind meth_name loc
 552
 553      meth_prags = find_prags meth_name prags
 554    in
 555
 556         -- Warn if no method binding, only if -fwarn-missing-methods
 557    if no_user_bind && not supply_default_bind then
 558         pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
 559    else
 560    warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
 561           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 562
 563         -- Check the bindings; first add inst_tyvars to the envt
 564         -- so that we don't quantify over them in nested places
 565         -- The *caller* put the class/inst decl tyvars into the envt
 566    tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
 567      tcAddErrCtxt (methodCtxt sel_id)           $
 568      tcBindWithSigs NotTopLevel meth_bind
 569                     [sig_info] meth_prags NonRecursive
 570    )                                            `thenTc` \ (binds, insts, _) ->
 571
 572
 573    tcExtendLocalValEnv [(meth_name, meth_id)] (
 574         tcSpecSigs meth_prags
 575    )                                            `thenTc` \ (prag_binds1, prag_lie) ->
 576
 577         -- The prag_lie for a SPECIALISE pragma will mention the function
 578         -- itself, so we have to simplify them away right now lest they float
 579         -- outwards!
 580    bindInstsOfLocalFuns prag_lie [meth_id]      `thenTc` \ (prag_lie', prag_binds2) ->
 581
 582
 583         -- Now check that the instance type variables
 584         -- (or, in the case of a class decl, the class tyvars)
 585         -- have not been unified with anything in the environment
 586    tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id)))  $
 587    checkSigTyVars inst_tyvars                                           `thenTc_`
 588
 589    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 590              insts `plusLIE` prag_lie',
 591              meth)
 592  where
 593    sig_msg ty = sep [ptext SLIT("When checking the expected type for"),
 594                     nest 4 (ppr sel_name <+> dcolon <+> ppr ty)]
 595
 596    sel_name = idName sel_id
 597
 598         -- The renamer just puts the selector ID as the binder in the method binding
 599         -- but we must use the method name; so we substitute it here.  Crude but simple.
 600    find_bind meth_name (FunMonoBind op_name fix matches loc)
 601         | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
 602    find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
 603         | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
 604    find_bind meth_name (AndMonoBinds b1 b2)
 605                               = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
 606    find_bind meth_name other  = Nothing -- Default case
 607
 608
 609         -- Find the prags for this method, and replace the
 610         -- selector name with the method name
 611    find_prags meth_name [] = []
 612    find_prags meth_name (SpecSig name ty loc : prags)
 613         | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags
 614    find_prags meth_name (InlineSig name phase loc : prags)
 615         | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags
 616    find_prags meth_name (NoInlineSig name phase loc : prags)
 617         | name == sel_name = NoInlineSig meth_name phase loc : find_prags meth_name prags
 618    find_prags meth_name (prag:prags) = find_prags meth_name prags
 619
 620    mk_default_bind local_meth_name loc
 621       = PatMonoBind (VarPatIn local_meth_name)
 622                     (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
 623                     loc
 624
 625    default_expr loc
 626       = case maybe_dm_id of
 627           Just dm_id -> HsVar (getName dm_id)   -- There's a default method
 628           Nothing    -> error_expr loc          -- No default method
 629
 630    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 631                           (HsLit (HsString (_PK_ (error_msg loc))))
 632
 633    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 634 \end{code}
 635
 636 Contexts and errors
 637 ~~~~~~~~~~~~~~~~~~~
 638 \begin{code}
 639 classArityErr class_name
 640   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 641
 642 superClassErr class_name sc
 643   = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
 644     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 645
 646 defltMethCtxt class_name
 647   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
 648
 649 methodCtxt sel_id
 650   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 651
 652 badMethodErr bndr clas
 653   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 654           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 655
 656 omittedMethodWarn sel_id clas
 657   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 658          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 659 \end{code}