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