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