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, tcMethodBind, badMethodErr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
  12                           InPat(..), HsBinds(..), GRHSs(..),
  13                           HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
  14                           unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
  15                           isClassDecl, isClassOpSig
  16                         )
  17 import HsPragmas        ( ClassPragmas(..) )
  18 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
  19 import RnHsSyn          ( RenamedTyClDecl, RenamedClassPragmas,
  20                           RenamedClassOpSig, RenamedMonoBinds,
  21                           RenamedContext, RenamedHsDecl, RenamedSig
  22                         )
  23 import TcHsSyn          ( TcMonoBinds )
  24
  25 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
  26 import TcEnv            ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
  27                           tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
  28                           tcExtendLocalValEnv
  29                         )
  30 import TcBinds          ( tcBindWithSigs, tcPragmaSigs )
  31 import TcUnify          ( unifyKinds )
  32 import TcMonad
  33 import TcMonoType       ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
  34                           tcContext, checkSigTyVars, sigCtxt, mkTcSig
  35                         )
  36 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  37 import TcType           ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
  38 import PrelVals         ( nO_METHOD_BINDING_ERROR_ID )
  39 import FieldLabel       ( firstFieldLabelTag )
  40 import Bag              ( unionManyBags )
  41 import Class            ( mkClass, classBigSig, Class )
  42 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
  43 import MkId             ( mkSuperDictSelId, mkDataConId,
  44                           mkMethodSelId, mkDefaultMethodId
  45                         )
  46 import DataCon          ( mkDataCon )
  47 import Id               ( Id,
  48                           getIdUnfolding, idType, idName
  49                         )
  50 import CoreUnfold       ( getUnfoldingTemplate )
  51 import IdInfo
  52 import Name             ( Name, isLocallyDefined, NamedThing(..) )
  53 import Outputable
  54 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
  55                           mkSigmaTy, mkForAllTys, Type, ThetaType,
  56                           boxedTypeKind, mkArrowKind
  57                         )
  58 import Var              ( tyVarKind, TyVar )
  59 import VarSet           ( mkVarSet )
  60 import TyCon            ( mkAlgTyCon )
  61 import Unique           ( Unique, Uniquable(..) )
  62 import Util
  63 import Maybes           ( seqMaybe )
  64
  65
  66 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  67 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  68 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
  69                                                    noIdInfo)
  70 \end{code}
  71
  72
  73
  74 Dictionary handling
  75 ~~~~~~~~~~~~~~~~~~~
  76 Every class implicitly declares a new data type, corresponding to dictionaries
  77 of that class. So, for example:
  78
  79         class (D a) => C a where
  80           op1 :: a -> a
  81           op2 :: forall b. Ord b => a -> b -> b
  82
  83 would implicitly declare
  84
  85         data CDict a = CDict (D a)
  86                              (a -> a)
  87                              (forall b. Ord b => a -> b -> b)
  88
  89 (We could use a record decl, but that means changing more of the existing apparatus.
  90 One step at at time!)
  91
  92 For classes with just one superclass+method, we use a newtype decl instead:
  93
  94         class C a where
  95           op :: forallb. a -> b -> b
  96
  97 generates
  98
  99         newtype CDict a = CDict (forall b. a -> b -> b)
 100
 101 Now DictTy in Type is just a form of type synomym:
 102         DictTy c t = TyConTy CDict `AppTy` t
 103
 104 Death to "ExpandingDicts".
 105
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection{Kind checking}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 \begin{code}
 114 kcClassDecl (ClassDecl  context class_name
 115                         tyvar_names class_sigs def_methods pragmas
 116                         tycon_name datacon_name src_loc)
 117   =         -- CHECK ARITY 1 FOR HASKELL 1.4
 118     checkTc (opt_GlasgowExts || length tyvar_names == 1)
 119             (classArityErr class_name)          `thenTc_`
 120
 121         -- Get the (mutable) class kind
 122     tcLookupTy class_name                       `thenNF_Tc` \ (kind, _, _) ->
 123
 124         -- Make suitable tyvars and do kind checking
 125         -- The net effect is to mutate the class kind
 126     tcExtendTopTyVarScope kind tyvar_names      $ \ _ _ ->
 127     tcContext context                           `thenTc_`
 128     mapTc kc_sig the_class_sigs                 `thenTc_`
 129
 130     returnTc ()
 131   where
 132     the_class_sigs = filter isClassOpSig class_sigs
 133
 134     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Type checking}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 tcClassDecl1 rec_env rec_inst_mapper
 146              (ClassDecl context class_name
 147                         tyvar_names class_sigs def_methods pragmas
 148                         tycon_name datacon_name src_loc)
 149   =     -- LOOK THINGS UP IN THE ENVIRONMENT
 150     tcLookupTy class_name                               `thenTc` \ (class_kind, _, AClass rec_class) ->
 151     tcExtendTopTyVarScope class_kind tyvar_names        $ \ tyvars _ ->
 152         -- The class kind is by now immutable
 153
 154         -- CHECK THE CONTEXT
 155 --  traceTc (text "tcClassCtxt" <+> ppr class_name)     `thenTc_`
 156     tcClassContext class_name rec_class tyvars context pragmas
 157                                                 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 158 --  traceTc (text "tcClassCtxt done" <+> ppr class_name)        `thenTc_`
 159
 160         -- CHECK THE CLASS SIGNATURES,
 161     mapTc (tcClassSig rec_env rec_class tyvars)
 162           (filter isClassOpSig class_sigs)
 163                                                 `thenTc` \ sig_stuff ->
 164
 165         -- MAKE THE CLASS OBJECT ITSELF
 166     let
 167         (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
 168         rec_class_inst_env = rec_inst_mapper rec_class
 169         clas = mkClass class_name tyvars
 170                        sc_theta sc_sel_ids op_sel_ids defm_ids
 171                        tycon
 172                        rec_class_inst_env
 173
 174         dict_component_tys = sc_tys ++ op_tys
 175         new_or_data = case dict_component_tys of
 176                         [_]   -> NewType
 177                         other -> DataType
 178
 179         dict_con = mkDataCon datacon_name
 180                            [NotMarkedStrict | _ <- dict_component_tys]
 181                            [{- No labelled fields -}]
 182                            tyvars
 183                            [{-No context-}]
 184                            [{-No existential tyvars-}] [{-Or context-}]
 185                            dict_component_tys
 186                            tycon dict_con_id
 187         dict_con_id = mkDataConId dict_con
 188
 189         tycon = mkAlgTyCon tycon_name
 190                             class_kind
 191                             tyvars
 192                             []                  -- No context
 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                -> RenamedClassPragmas   -- pragmas for superclasses
 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 pragmas
 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     in
 228
 229         -- Make super-class selector ids
 230         -- We number them off, 1, 2, 3 etc so that we can construct
 231         -- names for the selectors.  Thus
 232         --      class (C a, C b) => D a b where ...
 233         -- gives superclass selectors
 234         --      D_sc1, D_sc2
 235         -- (We used to call them D_C, but now we can have two different
 236         --  superclasses both called C!)
 237     mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..])   `thenTc` \ sc_sel_ids ->
 238
 239         -- Done
 240     returnTc (sc_theta, sc_tys, sc_sel_ids)
 241
 242   where
 243     rec_tyvar_tys = mkTyVarTys rec_tyvars
 244
 245     mk_super_id ((super_class, tys), index)
 246         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 247           let
 248                 ty = mkForAllTys rec_tyvars $
 249                      mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
 250           in
 251           returnTc (mkSuperDictSelId uniq rec_class index ty)
 252
 253     check_constraint (c, tys) = checkTc (all is_tyvar tys)
 254                                         (superClassErr class_name (c, tys))
 255
 256     is_tyvar (MonoTyVar _) = True
 257     is_tyvar other         = False
 258
 259
 260 tcClassSig :: ValueEnv          -- Knot tying only!
 261            -> Class                     -- ...ditto...
 262            -> [TyVar]                   -- The class type variable, used for error check only
 263            -> RenamedClassOpSig
 264            -> TcM s (Type,              -- Type of the method
 265                      Id,                -- selector id
 266                      Maybe Id)          -- default-method ids
 267
 268 tcClassSig rec_env rec_clas rec_clas_tyvars
 269            (ClassOpSig op_name maybe_dm_name
 270                        op_ty
 271                        src_loc)
 272   = tcAddSrcLoc src_loc $
 273
 274         -- Check the type signature.  NB that the envt *already has*
 275         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 276
 277     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 278     -- and that it is not constrained by theta
 279 --  traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
 280     tcHsTopType op_ty                           `thenTc` \ local_ty ->
 281     let
 282         global_ty   = mkSigmaTy rec_clas_tyvars
 283                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 284                                 local_ty
 285
 286         -- Build the selector id and default method id
 287         sel_id      = mkMethodSelId op_name rec_clas global_ty
 288         maybe_dm_id = case maybe_dm_name of
 289                            Nothing      -> Nothing
 290                            Just dm_name -> let
 291                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 292                                            in
 293                                            Just (tcAddImportedIdInfo rec_env dm_id)
 294     in
 295 --  traceTc (text "tcClassSig done" <+> ppr op_name)    `thenTc_`
 296     returnTc (local_ty, sel_id, maybe_dm_id)
 297 \end{code}
 298
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 The purpose of pass 2 is
 307 \begin{enumerate}
 308 \item
 309 to beat on the explicitly-provided default-method decls (if any),
 310 using them to produce a complete set of default-method decls.
 311 (Omitted ones elicit an error message.)
 312 \item
 313 to produce a definition for the selector function for each method
 314 and superclass dictionary.
 315 \end{enumerate}
 316
 317 Pass~2 only applies to locally-defined class declarations.
 318
 319 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 320 each local class decl.
 321
 322 \begin{code}
 323 tcClassDecls2 :: [RenamedHsDecl]
 324               -> NF_TcM s (LIE, TcMonoBinds)
 325
 326 tcClassDecls2 decls
 327   = foldr combine
 328           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 329           [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
 330   where
 331     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 332                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 333                       returnNF_Tc (lie1 `plusLIE` lie2,
 334                                    binds1 `AndMonoBinds` binds2)
 335 \end{code}
 336
 337 @tcClassDecl2@ is the business end of things.
 338
 339 \begin{code}
 340 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 341              -> NF_TcM s (LIE, TcMonoBinds)
 342
 343 tcClassDecl2 (ClassDecl context class_name
 344                         tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 345
 346   | not (isLocallyDefined class_name)
 347   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 348
 349   | otherwise   -- It is locally defined
 350   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 351     tcAddSrcLoc src_loc                                   $
 352
 353         -- Get the relevant class
 354     tcLookupClass class_name                            `thenNF_Tc` \ clas ->
 355     let
 356         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 357
 358         -- The selector binds are already in the selector Id's unfoldings
 359 --      sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
 360 --                  | sel_id <- sc_sel_ids ++ op_sel_ids,
 361 --                    isLocallyDefined sel_id
 362 --                  ]
 363 --
 364 --      final_sel_binds = andMonoBindList sel_binds
 365     in
 366         -- Generate bindings for the default methods
 367     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 368
 369     returnTc (const_insts, meth_binds)
 370 --            final_sel_binds `AndMonoBinds` meth_binds)
 371 -- Leave 'em out for now.  They always get inlined anyway.  SLPJ June '98
 372 \end{code}
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsection[Default methods]{Default methods}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 The default methods for a class are each passed a dictionary for the
 381 class, so that they get access to the other methods at the same type.
 382 So, given the class decl
 383 \begin{verbatim}
 384 class Foo a where
 385         op1 :: a -> Bool
 386         op2 :: Ord b => a -> b -> b -> b
 387
 388         op1 x = True
 389         op2 x y z = if (op1 x) && (y < z) then y else z
 390 \end{verbatim}
 391 we get the default methods:
 392 \begin{verbatim}
 393 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 394 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 395
 396 ====================== OLD ==================
 397 \begin{verbatim}
 398 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 399 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 400                   if (op1 a dfoo x) && (< b dord y z) then y else z
 401 \end{verbatim}
 402 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 403 ====================== END OF OLD ===================
 404
 405 NEW:
 406 \begin{verbatim}
 407 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 408 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 409                   if (op1 a dfoo x) && (< b dord y z) then y else z
 410 \end{verbatim}
 411
 412
 413 When we come across an instance decl, we may need to use the default
 414 methods:
 415 \begin{verbatim}
 416 instance Foo Int where {}
 417 \end{verbatim}
 418 gives
 419 \begin{verbatim}
 420 const.Foo.Int.op1 :: Int -> Bool
 421 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 422
 423 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 424 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 425
 426 dfun.Foo.Int :: Foo Int
 427 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 428 \end{verbatim}
 429 Notice that, as with method selectors above, we assume that dictionary
 430 application is curried, so there's no need to mention the Ord dictionary
 431 in const.Foo.Int.op2 (or the type variable).
 432
 433 \begin{verbatim}
 434 instance Foo a => Foo [a] where {}
 435
 436 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 437 dfun.Foo.List
 438   = /\ a -> \ dfoo_a ->
 439     let rec
 440         op1 = defm.Foo.op1 [a] dfoo_list
 441         op2 = defm.Foo.op2 [a] dfoo_list
 442         dfoo_list = (op1, op2)
 443     in
 444         dfoo_list
 445 \end{verbatim}
 446
 447 \begin{code}
 448 tcDefaultMethodBinds
 449         :: Class
 450         -> RenamedMonoBinds
 451         -> TcM s (LIE, TcMonoBinds)
 452
 453 tcDefaultMethodBinds clas default_binds
 454   =     -- Construct suitable signatures
 455     tcInstTyVars tyvars         `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 456
 457         -- Typecheck the default bindings
 458     let
 459         theta = [(clas,inst_tys)]
 460         tc_dm sel_id_w_dm@(_, Just dm_id)
 461           = tcMethodBind clas origin clas_tyvars inst_tys theta
 462                          default_binds [{-no prags-}] False
 463                          sel_id_w_dm            `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 464             returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id))
 465     in
 466     tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 467         mapAndUnzip3Tc tc_dm sel_ids_w_dms
 468     )                                           `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 469
 470
 471         -- Check the context
 472     newDicts origin theta                       `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 473     let
 474         avail_insts = this_dict
 475     in
 476     tcAddErrCtxt (defltMethCtxt clas) $
 477
 478         -- tcMethodBind has checked that the class_tyvars havn't
 479         -- been unified with each other or another type, but we must
 480         -- still zonk them before passing them to tcSimplifyAndCheck
 481     mapNF_Tc zonkTcTyVarBndr clas_tyvars        `thenNF_Tc` \ clas_tyvars' ->
 482
 483     tcSimplifyAndCheck
 484         (ptext SLIT("class") <+> ppr clas)
 485         (mkVarSet clas_tyvars')
 486         avail_insts
 487         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 488
 489     let
 490         full_binds = AbsBinds
 491                         clas_tyvars'
 492                         [this_dict_id]
 493                         abs_bind_stuff
 494                         (dict_binds `andMonoBinds` andMonoBindList defm_binds)
 495     in
 496     returnTc (const_lie, full_binds)
 497
 498   where
 499     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 500
 501     sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
 502                         -- Just the ones for which there is an explicit
 503                         -- user default declaration
 504
 505     origin = ClassDeclOrigin
 506 \end{code}
 507
 508 @tcMethodBind@ is used to type-check both default-method and
 509 instance-decl method declarations.  We must type-check methods one at a
 510 time, because their signatures may have different contexts and
 511 tyvar sets.
 512
 513 \begin{code}
 514 tcMethodBind
 515         :: Class
 516         -> InstOrigin
 517         -> [TcTyVar]            -- Instantiated type variables for the
 518                                 --  enclosing class/instance decl.
 519                                 --  They'll be signature tyvars, and we
 520                                 --  want to check that they don't get bound
 521         -> [TcType]             -- Instance types
 522         -> TcThetaType          -- Available theta; this could be used to check
 523                                 --  the method signature, but actually that's done by
 524                                 --  the caller;  here, it's just used for the error message
 525         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 526         -> [RenamedSig]         -- Pramgas (just for this one)
 527         -> Bool                 -- True <=> supply default decl if no explicit decl
 528                                 --              This is true for instance decls,
 529                                 --              false for class decls
 530         -> (Id, Maybe Id)       -- The method selector and default-method Id
 531         -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
 532
 533 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 534              meth_binds prags supply_default_bind
 535              (sel_id, maybe_dm_id)
 536  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 537
 538    newMethod origin sel_id inst_tys     `thenNF_Tc` \ meth@(_, meth_id) ->
 539    mkTcSig meth_id loc                  `thenNF_Tc` \ sig_info ->
 540
 541    let
 542      meth_name       = idName meth_id
 543      maybe_user_bind = find_bind meth_name meth_binds
 544
 545      no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 546      no_user_default = case maybe_dm_id     of {Nothing -> True; other -> False}
 547
 548      meth_bind = case maybe_user_bind of
 549                         Just bind -> bind
 550                         Nothing   -> mk_default_bind meth_name loc
 551
 552      meth_prags = find_prags meth_name prags
 553    in
 554
 555         -- Warn if no method binding, only if -fwarn-missing-methods
 556    if no_user_bind && not supply_default_bind then
 557         pprPanic "tcMethodBind" (ppr clas <+> ppr inst_tys)
 558    else
 559    warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
 560           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 561
 562         -- Check the pragmas
 563    tcExtendLocalValEnv [(meth_name, meth_id)] (
 564         tcPragmaSigs meth_prags
 565    )                                            `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
 566
 567         -- Check the bindings; first add inst_tyvars to the envt
 568         -- so that we don't quantify over them in nested places
 569         -- The *caller* put the class/inst decl tyvars into the envt
 570    tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
 571      tcAddErrCtxt (methodCtxt sel_id)           $
 572      tcBindWithSigs NotTopLevel meth_bind [sig_info]
 573                     NonRecursive prag_info_fn
 574    )                                            `thenTc` \ (binds, insts, _) ->
 575
 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 spec loc : prags)
 613         | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
 614    find_prags meth_name (InlineSig name loc : prags)
 615         | name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
 616    find_prags meth_name (NoInlineSig name loc : prags)
 617         | name == sel_name = NoInlineSig meth_name 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}