ghc/compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcClassDcl]{Typechecking class declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
  14                           Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
  15                           HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
  16                           Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
  17 import HsPragmas        ( ClassPragmas(..) )
  18 import RnHsSyn          ( RenamedClassDecl(..), RenamedClassPragmas(..),
  19                           RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
  20                           RenamedGenPragmas(..), RenamedContext(..),
  21                           RnName{-instance Uniquable-}
  22                         )
  23 import TcHsSyn          ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
  24                           mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
  25
  26 import Inst             ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
  27 import TcEnv            ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
  28 import TcInstDcls       ( processInstBinds )
  29 import TcKind           ( unifyKind, TcKind )
  30 import TcMonad          hiding ( rnMtoTcM )
  31 import TcMonoType       ( tcPolyType, tcMonoType, tcContext )
  32 import TcSimplify       ( tcSimplifyAndCheck )
  33 import TcType           ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
  34
  35 import Bag              ( foldBag, unionManyBags )
  36 import Class            ( GenClass, mkClass, mkClassOp, classBigSig,
  37                           classOps, classOpString, classOpLocalType,
  38                           classOpTagByString, SYN_IE(ClassOp)
  39                         )
  40 import Id               ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
  41                           idType )
  42 import IdInfo
  43 import Name             ( isLocallyDefined, origName, getLocalName )
  44 import PrelVals         ( nO_DEFAULT_METHOD_ERROR_ID )
  45 import PprStyle
  46 import Pretty
  47 import PprType          ( GenType, GenTyVar, GenClassOp )
  48 import SpecEnv          ( SpecEnv )
  49 import SrcLoc           ( mkGeneratedSrcLoc )
  50 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
  51                           mkForAllTy, mkSigmaTy, splitSigmaTy)
  52 import TysWiredIn       ( stringTy )
  53 import TyVar            ( unitTyVarSet, GenTyVar )
  54 import Unique           ( Unique )
  55 import Util
  56
  57
  58 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  59 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  60 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec,
  61                                                    noIdInfo)
  62 \end{code}
  63
  64
  65
  66 Dictionary handling
  67 ~~~~~~~~~~~~~~~~~~~
  68 Every class implicitly declares a new data type, corresponding to dictionaries
  69 of that class. So, for example:
  70
  71         class (D a) => C a where
  72           op1 :: a -> a
  73           op2 :: forall b. Ord b => a -> b -> b
  74
  75 would implicitly declare
  76
  77         data CDict a = CDict (D a)
  78                              (a -> a)
  79                              (forall b. Ord b => a -> b -> b)
  80
  81 (We could use a record decl, but that means changing more of the existing apparatus.
  82 One step at at time!)
  83
  84 For classes with just one superclass+method, we use a newtype decl instead:
  85
  86         class C a where
  87           op :: forallb. a -> b -> b
  88
  89 generates
  90
  91         newtype CDict a = CDict (forall b. a -> b -> b)
  92
  93 Now DictTy in Type is just a form of type synomym:
  94         DictTy c t = TyConTy CDict `AppTy` t
  95
  96 Death to "ExpandingDicts".
  97
  98
  99 \begin{code}
 100 tcClassDecl1 rec_inst_mapper
 101              (ClassDecl context class_name
 102                         tyvar_name class_sigs def_methods pragmas src_loc)
 103   = tcAddSrcLoc src_loc $
 104     tcAddErrCtxt (classDeclCtxt class_name) $
 105
 106         -- LOOK THINGS UP IN THE ENVIRONMENT
 107     tcLookupClass class_name    `thenNF_Tc` \ (class_kind, rec_class) ->
 108     tcLookupTyVar tyvar_name    `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
 109     let
 110         (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
 111     in
 112
 113         -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
 114     unifyKind class_kind tyvar_kind     `thenTc_`
 115
 116         -- CHECK THE CONTEXT
 117     tcClassContext rec_class rec_tyvar context pragmas
 118                                 `thenTc` \ (scs, sc_sel_ids) ->
 119
 120         -- CHECK THE CLASS SIGNATURES,
 121     mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
 122                                 `thenTc` \ sig_stuff ->
 123
 124         -- MAKE THE CLASS OBJECT ITSELF
 125     let
 126         (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
 127         clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
 128                        scs sc_sel_ids ops op_sel_ids defm_ids
 129                        rec_class_inst_env
 130     in
 131     returnTc clas
 132 \end{code}
 133
 134
 135     let
 136         clas_ty = mkTyVarTy clas_tyvar
 137         dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
 138                              [classOpLocalType op | op <- ops])
 139         new_or_data = case dict_component_tys of
 140                         [_]   -> NewType
 141                         other -> DataType
 142
 143         dict_con_id = mkDataCon class_name
 144                            [NotMarkedStrict]
 145                            [{- No labelled fields -}]
 146                            [clas_tyvar]
 147                            [{-No context-}]
 148                            dict_component_tys
 149                            tycon
 150
 151         tycon = mkDataTyCon class_name
 152                             (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
 153                             [rec_tyvar]
 154                             [{- Empty context -}]
 155                             [dict_con_id]
 156                             [{- No derived classes -}]
 157                             new_or_data
 158     in
 159
 160
 161 \begin{code}
 162 tcClassContext :: Class -> TyVar
 163                -> RenamedContext        -- class context
 164                -> RenamedClassPragmas   -- pragmas for superclasses
 165                -> TcM s ([Class],       -- the superclasses
 166                          [Id])          -- superclass selector Ids
 167
 168 tcClassContext rec_class rec_tyvar context pragmas
 169   =     -- Check the context.
 170         -- The renamer has already checked that the context mentions
 171         -- only the type variable of the class decl.
 172     tcContext context                   `thenTc` \ theta ->
 173     let
 174       super_classes = [ supers | (supers, _) <- theta ]
 175     in
 176
 177         -- Make super-class selector ids
 178     mapTc (mk_super_id rec_class)
 179           (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
 180           -- NB: we worry about matching list lengths below
 181
 182         -- Done
 183     returnTc (super_classes, sc_sel_ids)
 184
 185   where
 186     mk_super_id rec_class (super_class, maybe_pragma)
 187         = fixTc ( \ rec_super_id ->
 188             tcGetUnique                 `thenNF_Tc` \ uniq ->
 189
 190                 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
 191             (case maybe_pragma of
 192                 Nothing   -> returnNF_Tc noIdInfo
 193                 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
 194             )                           `thenNF_Tc` \ id_info ->
 195             let
 196                 rec_tyvar_ty = mkTyVarTy rec_tyvar
 197                 ty = mkForAllTy rec_tyvar $
 198                      mkFunTy (mkDictTy rec_class   rec_tyvar_ty)
 199                              (mkDictTy super_class rec_tyvar_ty)
 200             in
 201                 -- BUILD THE SUPERCLASS ID
 202             returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
 203           )
 204
 205     maybe_pragmas :: [Maybe RenamedGenPragmas]
 206     maybe_pragmas = case pragmas of
 207                         NoClassPragmas         -> repeat Nothing
 208                         SuperDictPragmas prags -> ASSERT(length prags == length context)
 209                                                   map Just prags
 210                         -- If there are any pragmas there should
 211                         -- be one for each superclass
 212
 213
 214
 215 tcClassSig :: Class                     -- Knot tying only!
 216            -> TyVar                     -- The class type variable, used for error check only
 217            -> (ClassOp -> SpecEnv)      -- Ditto; the spec info for the class ops
 218            -> RenamedClassOpSig
 219            -> TcM s (ClassOp,           -- class op
 220                      Id,                -- selector id
 221                      Id)                -- default-method ids
 222
 223 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
 224            (ClassOpSig op_name
 225                        op_ty
 226                        pragmas src_loc)
 227   = tcAddSrcLoc src_loc $
 228     fixTc ( \ ~(_, rec_sel_id, rec_defm_id) ->  -- Knot for pragmas
 229
 230         -- Check the type signature.  NB that the envt *already has*
 231         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 232
 233     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 234     -- and that it is not constrained by theta
 235     tcPolyType op_ty                            `thenTc` \ local_ty ->
 236     let
 237         global_ty   = mkSigmaTy [rec_clas_tyvar]
 238                                 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
 239                                 local_ty
 240         class_op_nm = getLocalName op_name
 241         class_op    = mkClassOp class_op_nm
 242                                 (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
 243                                 local_ty
 244     in
 245
 246         -- Munch the pragmas
 247     tcClassOpPragmas
 248                 global_ty
 249                 rec_sel_id rec_defm_id
 250                 (rec_classop_spec_fn class_op)
 251                 pragmas                         `thenNF_Tc` \ (op_info, defm_info) ->
 252
 253         -- Build the selector id and default method id
 254     tcGetUnique                                 `thenNF_Tc` \ d_uniq ->
 255     let
 256         op_uniq = uniqueOf op_name
 257         sel_id  = mkMethodSelId     op_uniq rec_clas class_op global_ty op_info
 258         defm_id = mkDefaultMethodId d_uniq  rec_clas class_op False global_ty defm_info
 259                         -- ToDo: improve the "False"
 260     in
 261     returnTc (class_op, sel_id, defm_id)
 262     )
 263 \end{code}
 264
 265
 266 %************************************************************************
 267 %*                                                                      *
 268 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 269 %*                                                                      *
 270 %************************************************************************
 271
 272 The purpose of pass 2 is
 273 \begin{enumerate}
 274 \item
 275 to beat on the explicitly-provided default-method decls (if any),
 276 using them to produce a complete set of default-method decls.
 277 (Omitted ones elicit an error message.)
 278 \item
 279 to produce a definition for the selector function for each method
 280 and superclass dictionary.
 281 \end{enumerate}
 282
 283 Pass~2 only applies to locally-defined class declarations.
 284
 285 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 286 each local class decl.
 287
 288 \begin{code}
 289 tcClassDecls2 :: Bag RenamedClassDecl
 290               -> NF_TcM s (LIE s, TcHsBinds s)
 291
 292 tcClassDecls2 decls
 293   = foldBag combine
 294             tcClassDecl2
 295             (returnNF_Tc (emptyLIE, EmptyBinds))
 296             decls
 297   where
 298     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 299                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 300                       returnNF_Tc (lie1 `plusLIE` lie2,
 301                                    binds1 `ThenBinds` binds2)
 302 \end{code}
 303
 304 @tcClassDecl2@ is the business end of things.
 305
 306 \begin{code}
 307 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 308              -> NF_TcM s (LIE s, TcHsBinds s)
 309
 310 tcClassDecl2 (ClassDecl context class_name
 311                         tyvar_name class_sigs default_binds pragmas src_loc)
 312
 313   | not (isLocallyDefined class_name)
 314   = returnNF_Tc (emptyLIE, EmptyBinds)
 315
 316   | otherwise   -- It is locally defined
 317   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
 318     tcAddSrcLoc src_loc                               $
 319
 320         -- Get the relevant class
 321     tcLookupClass class_name            `thenNF_Tc` \ (_, clas) ->
 322     let
 323         (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 324           = classBigSig clas
 325     in
 326     tcInstSigTyVars [tyvar]             `thenNF_Tc` \ ([clas_tyvar], _, _) ->
 327
 328         -- Generate bindings for the selector functions
 329     buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
 330                                         `thenNF_Tc` \ sel_binds ->
 331         -- Ditto for the methods
 332     buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
 333                                         `thenTc` \ (const_insts, meth_binds) ->
 334
 335     returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 \begin{code}
 345 buildSelectors :: Class                 -- The class object
 346                -> TyVar                 -- Class type variable
 347                -> TcTyVar s             -- Instantiated class type variable (TyVarTy)
 348                -> [Class] -> [Id]       -- Superclasses and selectors
 349                -> [ClassOp] -> [Id]     -- Class ops and selectors
 350                -> NF_TcM s (TcHsBinds s)
 351
 352 buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
 353   =
 354         -- Make new Ids for the components of the dictionary
 355     let
 356         clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
 357         mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
 358     in
 359     mapNF_Tc mk_op_ty ops                               `thenNF_Tc` \ op_tys ->
 360     newLocalIds (map classOpString ops) op_tys  `thenNF_Tc` \ method_ids ->
 361
 362     newDicts ClassDeclOrigin
 363              [ (super_clas, clas_tyvar_ty)
 364              | super_clas <- scs ]                      `thenNF_Tc` \ (_,dict_ids) ->
 365
 366     newDicts ClassDeclOrigin
 367              [ (clas, clas_tyvar_ty) ]                  `thenNF_Tc` \ (_,[clas_dict]) ->
 368
 369          -- Make suitable bindings for the selectors
 370     let
 371         mk_sel sel_id method_or_dict
 372           = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
 373     in
 374     listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
 375     listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids)   `thenNF_Tc` \ sc_sel_binds ->
 376
 377     returnNF_Tc (SingleBind (
 378                  NonRecBind (
 379                  foldr AndMonoBinds
 380                        (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
 381                        sc_sel_binds
 382                  )))
 383 \end{code}
 384
 385 %************************************************************************
 386 %*                                                                      *
 387 \subsection[ClassDcl-misc]{Miscellaneous}
 388 %*                                                                      *
 389 %************************************************************************
 390
 391 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
 392 consisting of @dicts@ and @methods@.
 393
 394 ======================  OLD ============================
 395 We have to do a bit of jiggery pokery to get the type variables right.
 396 Suppose we have the class decl:
 397 \begin{verbatim}
 398         class Foo a where
 399                 op1 :: Ord b => a -> b -> a
 400                 op2 :: ...
 401 \end{verbatim}
 402 Then the method selector for \tr{op1} is like this:
 403 \begin{verbatim}
 404         op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
 405                                          (op1_method,op2_method) -> op1_method b dOrd
 406 \end{verbatim}
 407 Note that the type variable for \tr{b} and the (Ord b) dictionary
 408 are lifted to the top lambda, and
 409 \tr{op1_method} is applied to them.  This is preferable to the alternative:
 410 \begin{verbatim}
 411         op1_sel' = /\a -> \dFoo -> case dFoo of
 412                                         (op1_method,op2_method) -> op1_method
 413 \end{verbatim}
 414 because \tr{op1_sel'} then has the rather strange type
 415 \begin{verbatim}
 416         op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
 417 \end{verbatim}
 418 whereas \tr{op1_sel} (the one we use) has the decent type
 419 \begin{verbatim}
 420         op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 421 \end{verbatim}
 422 ========================= END OF OLD ===========================
 423
 424 NEW COMMENT: instead we now go for op1_sel' above.  Seems tidier and
 425 the rest of the compiler darn well ought to cope.
 426
 427
 428
 429 NOTE that we return a TcMonoBinds (which is later zonked) even though
 430 there's no real back-substitution to do. It's just simpler this way!
 431
 432 NOTE ALSO that the selector has no free type variables, so we
 433 don't bother to instantiate the class-op's local type; instead
 434 we just use the variables inside it.
 435
 436 \begin{code}
 437 mkSelBind :: Id                         -- the selector id
 438           -> TcTyVar s -> TcIdOcc s     -- class tyvar and dict
 439           -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
 440           -> TcIdOcc s                  -- the superclass/method being slected
 441           -> NF_TcM s (TcMonoBinds s)
 442
 443 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
 444   =
 445         -- sel_id = /\ clas_tyvar -> \ clas_dict ->
 446         --          case clas_dict of
 447         --               <dicts..methods> -> method_or_dict
 448
 449     returnNF_Tc (VarMonoBind (RealId sel_id)  (
 450                  TyLam [clas_tyvar] (
 451                  DictLam [clas_dict] (
 452                  HsCase
 453                    (HsVar clas_dict)
 454                    ([PatMatch  (DictPat dicts methods) (
 455                      GRHSMatch (GRHSsAndBindsOut
 456                         [OtherwiseGRHS
 457                            (HsVar method_or_dict)
 458                            mkGeneratedSrcLoc]
 459                         EmptyBinds
 460                         (idType op)))])
 461                     mkGeneratedSrcLoc
 462                  ))))
 463 \end{code}
 464
 465
 466 %************************************************************************
 467 %*                                                                      *
 468 \subsection[Default methods]{Default methods}
 469 %*                                                                      *
 470 %************************************************************************
 471
 472 The default methods for a class are each passed a dictionary for the
 473 class, so that they get access to the other methods at the same type.
 474 So, given the class decl
 475 \begin{verbatim}
 476 class Foo a where
 477         op1 :: a -> Bool
 478         op2 :: Ord b => a -> b -> b -> b
 479
 480         op1 x = True
 481         op2 x y z = if (op1 x) && (y < z) then y else z
 482 \end{verbatim}
 483 we get the default methods:
 484 \begin{verbatim}
 485 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 486 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 487
 488 ====================== OLD ==================
 489 \begin{verbatim}
 490 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 491 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 492                   if (op1 a dfoo x) && (< b dord y z) then y else z
 493 \end{verbatim}
 494 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 495 ====================== END OF OLD ===================
 496
 497 NEW:
 498 \begin{verbatim}
 499 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 500 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 501                   if (op1 a dfoo x) && (< b dord y z) then y else z
 502 \end{verbatim}
 503
 504
 505 When we come across an instance decl, we may need to use the default
 506 methods:
 507 \begin{verbatim}
 508 instance Foo Int where {}
 509 \end{verbatim}
 510 gives
 511 \begin{verbatim}
 512 const.Foo.Int.op1 :: Int -> Bool
 513 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 514
 515 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 516 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 517
 518 dfun.Foo.Int :: Foo Int
 519 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 520 \end{verbatim}
 521 Notice that, as with method selectors above, we assume that dictionary
 522 application is curried, so there's no need to mention the Ord dictionary
 523 in const.Foo.Int.op2 (or the type variable).
 524
 525 \begin{verbatim}
 526 instance Foo a => Foo [a] where {}
 527
 528 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 529 dfun.Foo.List
 530   = /\ a -> \ dfoo_a ->
 531     let rec
 532         op1 = defm.Foo.op1 [a] dfoo_list
 533         op2 = defm.Foo.op2 [a] dfoo_list
 534         dfoo_list = (op1, op2)
 535     in
 536         dfoo_list
 537 \end{verbatim}
 538
 539 \begin{code}
 540 buildDefaultMethodBinds
 541         :: Class
 542         -> TcTyVar s
 543         -> [Id]
 544         -> RenamedMonoBinds
 545         -> TcM s (LIE s, TcHsBinds s)
 546
 547 buildDefaultMethodBinds clas clas_tyvar
 548                         default_method_ids default_binds
 549   = newDicts origin [(clas,inst_ty)]                    `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 550     mapAndUnzipNF_Tc mk_method default_method_ids       `thenNF_Tc` \ (insts_s, local_defm_ids) ->
 551     let
 552         avail_insts    = this_dict `plusLIE` unionManyBags insts_s      -- Insts available
 553         clas_tyvar_set = unitTyVarSet clas_tyvar
 554     in
 555     tcExtendGlobalTyVars clas_tyvar_set (
 556         processInstBinds
 557            clas
 558            (makeClassDeclDefaultMethodRhs clas local_defm_ids)
 559            avail_insts
 560            local_defm_ids
 561            default_binds
 562     )                                   `thenTc` \ (insts_needed, default_binds') ->
 563
 564     tcSimplifyAndCheck
 565         clas_tyvar_set
 566         avail_insts
 567         insts_needed                    `thenTc` \ (const_lie, dict_binds) ->
 568
 569
 570     let
 571         defm_binds = AbsBinds
 572                         [clas_tyvar]
 573                         [this_dict_id]
 574                         (local_defm_ids `zip` map RealId default_method_ids)
 575                         dict_binds
 576                         (RecBind default_binds')
 577     in
 578     returnTc (const_lie, defm_binds)
 579   where
 580     inst_ty = mkTyVarTy clas_tyvar
 581     mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty]
 582     origin = ClassDeclOrigin
 583 \end{code}
 584
 585 @makeClassDeclDefaultMethodRhs@ builds the default method for a
 586 class declaration when no explicit default method is given.
 587
 588 \begin{code}
 589 makeClassDeclDefaultMethodRhs
 590         :: Class
 591         -> [TcIdOcc s]
 592         -> Int
 593         -> NF_TcM s (TcExpr s)
 594
 595 makeClassDeclDefaultMethodRhs clas method_ids tag
 596   =     -- Return the expression
 597         --      error ty "No default method for ..."
 598         -- The interesting thing is that method_ty is a for-all type;
 599         -- this is fun, although unusual in a type application!
 600
 601     returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
 602                        (HsLitOut (HsString (_PK_ error_msg)) stringTy))
 603
 604 {-      OLD AND COMPLICATED
 605     tcInstSigType ()    `thenNF_Tc` \ method_ty ->
 606     let
 607         (tyvars, theta, tau) = splitSigmaTy method_ty
 608     in
 609     newDicts ClassDeclOrigin theta      `thenNF_Tc` \ (lie, dict_ids) ->
 610
 611     returnNF_Tc (mkHsTyLam tyvars (
 612                  mkHsDictLam dict_ids (
 613                  HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
 614                      (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
 615 -}
 616
 617   where
 618     (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas
 619
 620     method_id = method_ids  !! (tag-1)
 621     class_op  = (classOps clas) !! (tag-1)
 622
 623     error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
 624                  ++ (ppShow 80 (ppr PprForUser class_op))
 625                  ++ "\""
 626 \end{code}
 627
 628
 629 Contexts
 630 ~~~~~~~~
 631 \begin{code}
 632 classDeclCtxt class_name sty
 633   = ppCat [ppStr "In the class declaration for", ppr sty class_name]
 634 \end{code}