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(..), HsPred(..),
  16                           pprHsClassAssertion, unguardedRHS,
  17                           andMonoBinds, andMonoBindList, getTyVarName,
  18                           isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
  19                         )
  20 import HsPragmas        ( ClassPragmas(..) )
  21 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
  22 import RnHsSyn          ( RenamedTyClDecl, RenamedClassPragmas,
  23                           RenamedClassOpSig, RenamedMonoBinds,
  24                           RenamedContext, RenamedHsDecl, RenamedSig
  25                         )
  26 import TcHsSyn          ( TcMonoBinds )
  27
  28 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
  29 import TcEnv            ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
  30                           tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
  31                           tcExtendLocalValEnv
  32                         )
  33 import TcBinds          ( tcBindWithSigs, tcSpecSigs )
  34 import TcUnify          ( unifyKinds )
  35 import TcMonad
  36 import TcMonoType       ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
  37                           tcContext, checkSigTyVars, sigCtxt, mkTcSig
  38                         )
  39 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  40 import TcType           ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
  41 import PrelInfo         ( nO_METHOD_BINDING_ERROR_ID )
  42 import FieldLabel       ( firstFieldLabelTag )
  43 import Bag              ( unionManyBags, bagToList )
  44 import Class            ( mkClass, classBigSig, classSelIds, Class, ClassOpItem )
  45 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
  46 import MkId             ( mkDictSelId, mkDataConId, mkDefaultMethodId )
  47 import DataCon          ( mkDataCon, notMarkedStrict )
  48 import Id               ( Id, setInlinePragma, getIdUnfolding, idType, idName )
  49 import CoreUnfold       ( unfoldingTemplate )
  50 import IdInfo
  51 import Name             ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
  52 import NameSet          ( emptyNameSet )
  53 import Outputable
  54 import Type             ( Type, ThetaType, ClassContext,
  55                           mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
  56                           mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
  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 fundeps 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 fundeps 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 FUNCTIONAL DEPENDENCIES,
 157     tcFundeps fundeps                           `thenTc` \ fds ->
 158
 159         -- CHECK THE CLASS SIGNATURES,
 160     mapTc (tcClassSig rec_env rec_class tyvars)
 161           (filter isClassOpSig class_sigs)
 162                                                 `thenTc` \ sig_stuff ->
 163
 164         -- MAKE THE CLASS OBJECT ITSELF
 165     let
 166         (op_tys, op_items) = unzip sig_stuff
 167         rec_class_inst_env = rec_inst_mapper rec_class
 168         clas = mkClass class_name tyvars fds
 169                        sc_theta sc_sel_ids op_items
 170                        tycon
 171                        rec_class_inst_env
 172
 173         dict_component_tys = sc_tys ++ op_tys
 174         new_or_data = case dict_component_tys of
 175                         [_]   -> NewType
 176                         other -> DataType
 177
 178         dict_con = mkDataCon datacon_name
 179                            [notMarkedStrict | _ <- dict_component_tys]
 180                            [{- No labelled fields -}]
 181                            tyvars
 182                            [{-No context-}]
 183                            [{-No existential tyvars-}] [{-Or context-}]
 184                            dict_component_tys
 185                            tycon dict_con_id
 186
 187         dict_con_id = mkDataConId dict_con
 188
 189         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
 190                                                          ppr tycon_name)
 191                                       tycon_name
 192
 193         tycon = mkAlgTyCon tycon_name
 194                             class_kind
 195                             tyvars
 196                             []                  -- No context
 197                             argvrcs
 198                             [dict_con]          -- Constructors
 199                             []                  -- No derivings
 200                             (Just clas)         -- Yes!  It's a dictionary
 201                             new_or_data
 202                             NonRecursive
 203     in
 204     returnTc clas
 205 \end{code}
 206
 207 \begin{code}
 208 tcFundeps = mapTc tc_fundep
 209 tc_fundep (us, vs) =
 210     mapTc tc_fd_tyvar us        `thenTc` \ us' ->
 211     mapTc tc_fd_tyvar vs        `thenTc` \ vs' ->
 212     returnTc (us', vs')
 213 tc_fd_tyvar v =
 214     tcLookupTy v `thenTc` \(_, _, thing) ->
 215     case thing of
 216         ATyVar tv -> returnTc tv
 217         -- ZZ else should fail more gracefully
 218 \end{code}
 219
 220 \begin{code}
 221 tcClassContext :: Name -> Class -> [TyVar]
 222                -> RenamedContext        -- class context
 223                -> [Name]                -- Names for superclass selectors
 224                -> TcM s (ClassContext,  -- the superclass context
 225                          [Type],        -- types of the superclass dictionaries
 226                          [Id])          -- superclass selector Ids
 227
 228 tcClassContext class_name rec_class rec_tyvars context sc_sel_names
 229   =     -- Check the context.
 230         -- The renamer has already checked that the context mentions
 231         -- only the type variable of the class decl.
 232
 233         -- For std Haskell check that the context constrains only tyvars
 234     (if opt_GlasgowExts then
 235         returnTc []
 236      else
 237         mapTc check_constraint context
 238     )                                   `thenTc_`
 239
 240     tcContext context                   `thenTc` \ sc_theta ->
 241
 242     let
 243        sc_theta' = classesOfPreds sc_theta
 244        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
 245        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
 246     in
 247         -- Done
 248     returnTc (sc_theta', sc_tys, sc_sel_ids)
 249
 250   where
 251     rec_tyvar_tys = mkTyVarTys rec_tyvars
 252
 253     mk_super_id name dict_ty
 254         = mkDictSelId name rec_class ty
 255         where
 256           ty = mkForAllTys rec_tyvars $
 257                mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
 258
 259     check_constraint (HsPClass 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                      ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
 272
 273
 274 tcClassSig rec_env rec_clas rec_clas_tyvars
 275            (ClassOpSig op_name dm_name explicit_dm
 276                        op_ty src_loc)
 277   = tcAddSrcLoc src_loc $
 278
 279         -- Check the type signature.  NB that the envt *already has*
 280         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 281
 282     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 283     -- and that it is not constrained by theta
 284 --  traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
 285     tcHsTopType op_ty                           `thenTc` \ local_ty ->
 286     let
 287         global_ty   = mkSigmaTy rec_clas_tyvars
 288                                 [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)]
 289                                 local_ty
 290
 291         -- Build the selector id and default method id
 292         sel_id      = mkDictSelId op_name rec_clas global_ty
 293         dm_id       = mkDefaultMethodId dm_name rec_clas global_ty
 294         final_dm_id = tcAddImportedIdInfo rec_env dm_id
 295     in
 296 --  traceTc (text "tcClassSig done" <+> ppr op_name)    `thenTc_`
 297     returnTc (local_ty, (sel_id, final_dm_id, explicit_dm))
 298 \end{code}
 299
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 The purpose of pass 2 is
 308 \begin{enumerate}
 309 \item
 310 to beat on the explicitly-provided default-method decls (if any),
 311 using them to produce a complete set of default-method decls.
 312 (Omitted ones elicit an error message.)
 313 \item
 314 to produce a definition for the selector function for each method
 315 and superclass dictionary.
 316 \end{enumerate}
 317
 318 Pass~2 only applies to locally-defined class declarations.
 319
 320 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 321 each local class decl.
 322
 323 \begin{code}
 324 tcClassDecls2 :: [RenamedHsDecl]
 325               -> NF_TcM s (LIE, TcMonoBinds)
 326
 327 tcClassDecls2 decls
 328   = foldr combine
 329           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 330           [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
 331   where
 332     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 333                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 334                       returnNF_Tc (lie1 `plusLIE` lie2,
 335                                    binds1 `AndMonoBinds` binds2)
 336 \end{code}
 337
 338 @tcClassDecl2@ is the business end of things.
 339
 340 \begin{code}
 341 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 342              -> NF_TcM s (LIE, TcMonoBinds)
 343
 344 tcClassDecl2 (ClassDecl context class_name
 345                         tyvar_names _ class_sigs default_binds pragmas _ _ _ src_loc)
 346
 347   | not (isLocallyDefined class_name)
 348   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 349
 350   | otherwise   -- It is locally defined
 351   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 352     tcAddSrcLoc src_loc                                   $
 353
 354         -- Get the relevant class
 355     tcLookupClass class_name                            `thenNF_Tc` \ clas ->
 356     let
 357         -- The selector binds are already in the selector Id's unfoldings
 358         sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id))
 359                     | sel_id <- classSelIds clas
 360                     ]
 361     in
 362         -- Generate bindings for the default methods
 363     tcDefaultMethodBinds clas default_binds class_sigs          `thenTc` \ (const_insts, meth_binds) ->
 364
 365     returnTc (const_insts,
 366               meth_binds `AndMonoBinds` andMonoBindList sel_binds)
 367 \end{code}
 368
 369 %************************************************************************
 370 %*                                                                      *
 371 \subsection[Default methods]{Default methods}
 372 %*                                                                      *
 373 %************************************************************************
 374
 375 The default methods for a class are each passed a dictionary for the
 376 class, so that they get access to the other methods at the same type.
 377 So, given the class decl
 378 \begin{verbatim}
 379 class Foo a where
 380         op1 :: a -> Bool
 381         op2 :: Ord b => a -> b -> b -> b
 382
 383         op1 x = True
 384         op2 x y z = if (op1 x) && (y < z) then y else z
 385 \end{verbatim}
 386 we get the default methods:
 387 \begin{verbatim}
 388 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 389 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 390
 391 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 392 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 393                   if (op1 a dfoo x) && (< b dord y z) then y else z
 394 \end{verbatim}
 395
 396 When we come across an instance decl, we may need to use the default
 397 methods:
 398 \begin{verbatim}
 399 instance Foo Int where {}
 400 \end{verbatim}
 401 gives
 402 \begin{verbatim}
 403 const.Foo.Int.op1 :: Int -> Bool
 404 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 405
 406 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 407 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 408
 409 dfun.Foo.Int :: Foo Int
 410 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 411 \end{verbatim}
 412 Notice that, as with method selectors above, we assume that dictionary
 413 application is curried, so there's no need to mention the Ord dictionary
 414 in const.Foo.Int.op2 (or the type variable).
 415
 416 \begin{verbatim}
 417 instance Foo a => Foo [a] where {}
 418
 419 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 420 dfun.Foo.List
 421   = /\ a -> \ dfoo_a ->
 422     let rec
 423         op1 = defm.Foo.op1 [a] dfoo_list
 424         op2 = defm.Foo.op2 [a] dfoo_list
 425         dfoo_list = (op1, op2)
 426     in
 427         dfoo_list
 428 \end{verbatim}
 429
 430 \begin{code}
 431 tcDefaultMethodBinds
 432         :: Class
 433         -> RenamedMonoBinds
 434         -> [RenamedSig]
 435         -> TcM s (LIE, TcMonoBinds)
 436
 437 tcDefaultMethodBinds clas default_binds sigs
 438   =     -- Check that the default bindings come from this class
 439     checkFromThisClass clas op_items default_binds      `thenNF_Tc_`
 440
 441         -- Do each default method separately
 442         -- For Hugs compatibility we make a default-method for every
 443         -- class op, regardless of whether or not the programmer supplied an
 444         -- explicit default decl for the class.  GHC will actually never
 445         -- call the default method for such operations, because it'll whip up
 446         -- a more-informative default method at each instance decl.
 447     mapAndUnzipTc tc_dm op_items                `thenTc` \ (defm_binds, const_lies) ->
 448
 449     returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
 450   where
 451     prags = filter isPragSig sigs
 452
 453     (tyvars, _, _, op_items) = classBigSig clas
 454
 455     origin = ClassDeclOrigin
 456
 457     -- We make a separate binding for each default method.
 458     -- At one time I used a single AbsBinds for all of them, thus
 459     --  AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 460     -- But that desugars into
 461     --  ds = \d -> (..., ..., ...)
 462     --  dm1 = \d -> case ds d of (a,b,c) -> a
 463     -- And since ds is big, it doesn't get inlined, so we don't get good
 464     -- default methods.  Better to make separate AbsBinds for each
 465
 466     tc_dm op_item@(_, dm_id, _)
 467       = tcInstTyVars tyvars             `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
 468         let
 469             theta = [(mkClassPred clas inst_tys)]
 470         in
 471         newDicts origin theta                   `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 472         let
 473             avail_insts = this_dict
 474         in
 475         tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 476             tcMethodBind clas origin clas_tyvars inst_tys theta
 477                          default_binds prags False
 478                          op_item
 479         )                                       `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
 480
 481         tcAddErrCtxt (defltMethCtxt clas) $
 482
 483             -- tcMethodBind has checked that the class_tyvars havn't
 484             -- been unified with each other or another type, but we must
 485             -- still zonk them before passing them to tcSimplifyAndCheck
 486         mapNF_Tc zonkTcTyVarBndr clas_tyvars    `thenNF_Tc` \ clas_tyvars' ->
 487
 488             -- Check the context
 489         tcSimplifyAndCheck
 490             (ptext SLIT("class") <+> ppr clas)
 491             (mkVarSet clas_tyvars')
 492             avail_insts
 493             insts_needed                        `thenTc` \ (const_lie, dict_binds) ->
 494
 495         let
 496             full_bind = AbsBinds
 497                             clas_tyvars'
 498                             [this_dict_id]
 499                             [(clas_tyvars', dm_id, local_dm_id)]
 500                             emptyNameSet        -- No inlines (yet)
 501                             (dict_binds `andMonoBinds` defm_bind)
 502         in
 503         returnTc (full_bind, const_lie)
 504 \end{code}
 505
 506 \begin{code}
 507 checkFromThisClass :: Class -> [ClassOpItem] -> RenamedMonoBinds -> NF_TcM s ()
 508 checkFromThisClass clas op_items mono_binds
 509   = mapNF_Tc check_from_this_class bndrs        `thenNF_Tc_`
 510     returnNF_Tc ()
 511   where
 512     check_from_this_class (bndr, loc)
 513           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 514           | otherwise                         = tcAddSrcLoc loc $
 515                                                 addErrTc (badMethodErr bndr clas)
 516     sel_names = [getOccName sel_id | (sel_id,_,_) <- op_items]
 517     bndrs = bagToList (collectMonoBinders mono_binds)
 518 \end{code}
 519
 520
 521 @tcMethodBind@ is used to type-check both default-method and
 522 instance-decl method declarations.  We must type-check methods one at a
 523 time, because their signatures may have different contexts and
 524 tyvar sets.
 525
 526 \begin{code}
 527 tcMethodBind
 528         :: Class
 529         -> InstOrigin
 530         -> [TcTyVar]            -- Instantiated type variables for the
 531                                 --  enclosing class/instance decl.
 532                                 --  They'll be signature tyvars, and we
 533                                 --  want to check that they don't get bound
 534         -> [TcType]             -- Instance types
 535         -> TcThetaType          -- Available theta; this could be used to check
 536                                 --  the method signature, but actually that's done by
 537                                 --  the caller;  here, it's just used for the error message
 538         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 539         -> [RenamedSig]         -- Pramgas (just for this one)
 540         -> Bool                 -- True <=> This method is from an instance declaration
 541         -> ClassOpItem          -- The method selector and default-method Id
 542         -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
 543
 544 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 545              meth_binds prags is_inst_decl
 546              (sel_id, dm_id, explicit_dm)
 547  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 548
 549    newMethod origin sel_id inst_tys     `thenNF_Tc` \ meth@(_, meth_id) ->
 550    mkTcSig meth_id loc                  `thenNF_Tc` \ sig_info ->
 551
 552    let
 553      meth_name       = idName meth_id
 554      maybe_user_bind = find_bind meth_name meth_binds
 555
 556      no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 557
 558      meth_bind = case maybe_user_bind of
 559                         Just bind -> bind
 560                         Nothing   -> mk_default_bind meth_name loc
 561
 562      meth_prags = find_prags meth_name prags
 563    in
 564
 565         -- Warn if no method binding, only if -fwarn-missing-methods
 566    warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm)
 567           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 568
 569         -- Check the bindings; first add inst_tyvars to the envt
 570         -- so that we don't quantify over them in nested places
 571         -- The *caller* put the class/inst decl tyvars into the envt
 572    tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
 573      tcAddErrCtxt (methodCtxt sel_id)           $
 574      tcBindWithSigs NotTopLevel meth_bind
 575                     [sig_info] meth_prags NonRecursive
 576    )                                            `thenTc` \ (binds, insts, _) ->
 577
 578
 579    tcExtendLocalValEnv [(meth_name, meth_id)] (
 580         tcSpecSigs meth_prags
 581    )                                            `thenTc` \ (prag_binds1, prag_lie) ->
 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 loc : prags)
 619         | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags
 620    find_prags meth_name (InlineSig name phase loc : prags)
 621         | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags
 622    find_prags meth_name (NoInlineSig name phase loc : prags)
 623         | name == sel_name = NoInlineSig meth_name phase 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         | explicit_dm = HsVar (getName dm_id)   -- There's a default method
 633         | otherwise   = error_expr loc          -- No default method
 634
 635    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 636                           (HsLit (HsString (_PK_ (error_msg loc))))
 637
 638    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 639 \end{code}
 640
 641 Contexts and errors
 642 ~~~~~~~~~~~~~~~~~~~
 643 \begin{code}
 644 classArityErr class_name
 645   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 646
 647 superClassErr class_name sc
 648   = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
 649     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 650
 651 defltMethCtxt class_name
 652   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
 653
 654 methodCtxt sel_id
 655   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 656
 657 badMethodErr bndr clas
 658   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 659           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 660
 661 omittedMethodWarn sel_id clas
 662   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 663          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 664 \end{code}