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