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