ghc/compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcClassDcl]{Typechecking class declarations}
   5
   6 \begin{code}
   7 module TcClassDcl ( tcClassDecl1, tcClassDecls2,
   8                     tcMethodBind, badMethodErr
   9                   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( TyClDecl(..), Sig(..), MonoBinds(..),
  14                           HsExpr(..), HsLit(..), HsType(..), HsPred(..),
  15                           mkSimpleMatch, andMonoBinds, andMonoBindList,
  16                           isClassOpSig, isPragSig,
  17                           getClassDeclSysNames,
  18                         )
  19 import BasicTypes       ( TopLevelFlag(..), RecFlag(..) )
  20 import RnHsSyn          ( RenamedTyClDecl,
  21                           RenamedClassOpSig, RenamedMonoBinds,
  22                           RenamedContext, RenamedSig,
  23                           maybeGenericMatch
  24                         )
  25 import TcHsSyn          ( TcMonoBinds )
  26
  27 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
  28                           instToId, newDicts, newMethod )
  29 import TcEnv            ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
  30                           tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
  31                           tcExtendLocalValEnv, tcExtendTyVarEnv
  32                         )
  33 import TcBinds          ( tcBindWithSigs, tcSpecSigs )
  34 import TcMonoType       ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
  35 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  36 import TcType           ( TcType, TcTyVar, tcInstTyVars )
  37 import TcMonad
  38 import Generics         ( mkGenericRhs, validGenericMethodType )
  39 import PrelInfo         ( nO_METHOD_BINDING_ERROR_ID )
  40 import Class            ( classTyVars, classBigSig, classTyCon,
  41                           Class, ClassOpItem, DefMeth (..) )
  42 import MkId             ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
  43 import DataCon          ( mkDataCon, notMarkedStrict )
  44 import Id               ( Id, idType, idName )
  45 import Module           ( Module )
  46 import Name             ( Name, NamedThing(..) )
  47 import Name             ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
  48 import NameSet          ( emptyNameSet )
  49 import Outputable
  50 import Type             ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
  51                           splitTyConApp_maybe, isTyVarTy
  52                         )
  53 import Var              ( TyVar )
  54 import VarSet           ( mkVarSet, emptyVarSet )
  55 import CmdLineOpts
  56 import ErrUtils         ( dumpIfSet )
  57 import Util             ( count )
  58 import Maybes           ( seqMaybe, maybeToBool )
  59 \end{code}
  60
  61
  62
  63 Dictionary handling
  64 ~~~~~~~~~~~~~~~~~~~
  65 Every class implicitly declares a new data type, corresponding to dictionaries
  66 of that class. So, for example:
  67
  68         class (D a) => C a where
  69           op1 :: a -> a
  70           op2 :: forall b. Ord b => a -> b -> b
  71
  72 would implicitly declare
  73
  74         data CDict a = CDict (D a)
  75                              (a -> a)
  76                              (forall b. Ord b => a -> b -> b)
  77
  78 (We could use a record decl, but that means changing more of the existing apparatus.
  79 One step at at time!)
  80
  81 For classes with just one superclass+method, we use a newtype decl instead:
  82
  83         class C a where
  84           op :: forallb. a -> b -> b
  85
  86 generates
  87
  88         newtype CDict a = CDict (forall b. a -> b -> b)
  89
  90 Now DictTy in Type is just a form of type synomym:
  91         DictTy c t = TyConTy CDict `AppTy` t
  92
  93 Death to "ExpandingDicts".
  94
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection{Type checking}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 \begin{code}
 103
 104 tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
 105 tcClassDecl1 is_rec rec_env
 106              (ClassDecl {tcdCtxt = context, tcdName = class_name,
 107                          tcdTyVars = tyvar_names, tcdFDs = fundeps,
 108                          tcdSigs = class_sigs, tcdMeths = def_methods,
 109                          tcdSysNames = sys_names, tcdLoc = src_loc})
 110   =     -- CHECK ARITY 1 FOR HASKELL 1.4
 111     doptsTc Opt_GlasgowExts                             `thenTc` \ gla_ext_opt ->
 112     let
 113         gla_exts = gla_ext_opt || not (maybeToBool def_methods)
 114                 -- Accept extensions if gla_exts is on,
 115                 -- or if we're looking at an interface file decl
 116     in          -- (in which case def_methods = Nothing
 117
 118     checkTc (gla_exts || length tyvar_names == 1)
 119             (classArityErr class_name)                  `thenTc_`
 120
 121         -- LOOK THINGS UP IN THE ENVIRONMENT
 122     tcLookupClass class_name                            `thenTc` \ clas ->
 123     let
 124         tyvars   = classTyVars clas
 125         op_sigs  = filter isClassOpSig class_sigs
 126         op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
 127         (_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names
 128     in
 129     tcExtendTyVarEnv tyvars                             $
 130
 131         -- SOURCE-CODE CONSISTENCY CHECKS
 132     (case def_methods of
 133         Nothing  -> returnTc Nothing    -- Not source
 134         Just dms -> checkDefaultBinds clas op_names dms   `thenTc` \ dm_env ->
 135                     checkGenericClassIsUnary clas dm_env  `thenTc_`
 136                     returnTc (Just dm_env)
 137     )                                                      `thenTc` \ mb_dm_env ->
 138
 139         -- CHECK THE CONTEXT
 140     tcSuperClasses is_rec gla_exts clas context sc_sel_names    `thenTc` \ (sc_theta, sc_sel_ids) ->
 141
 142         -- CHECK THE CLASS SIGNATURES,
 143     mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs     `thenTc` \ sig_stuff ->
 144
 145         -- MAKE THE CLASS DETAILS
 146     let
 147         (op_tys, op_items) = unzip sig_stuff
 148         sc_tys             = mkDictTys sc_theta
 149         dict_component_tys = sc_tys ++ op_tys
 150
 151         dict_con = mkDataCon datacon_name
 152                              [notMarkedStrict | _ <- dict_component_tys]
 153                              [{- No labelled fields -}]
 154                              tyvars
 155                              [{-No context-}]
 156                              [{-No existential tyvars-}] [{-Or context-}]
 157                              dict_component_tys
 158                              (classTyCon clas)
 159                              dict_con_id dict_wrap_id
 160
 161         dict_con_id  = mkDataConId datacon_wkr_name dict_con
 162         dict_wrap_id = mkDataConWrapId dict_con
 163     in
 164     returnTc (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con)
 165 \end{code}
 166
 167 \begin{code}
 168 checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
 169                   -> TcM (NameEnv Bool)
 170         -- The returned environment says
 171         --      x not in env => no default method
 172         --      x -> True    => generic default method
 173         --      x -> False   => polymorphic default method
 174
 175   -- Check default bindings
 176   --    a) must be for a class op for this class
 177   --    b) must be all generic or all non-generic
 178   -- and return a mapping from class-op to DefMeth info
 179
 180   -- But do all this only for source binds
 181
 182 checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv
 183
 184 checkDefaultBinds clas ops (AndMonoBinds b1 b2)
 185   = checkDefaultBinds clas ops b1       `thenTc` \ dm_info1 ->
 186     checkDefaultBinds clas ops b2       `thenTc` \ dm_info2 ->
 187     returnTc (dm_info1 `plusNameEnv` dm_info2)
 188
 189 checkDefaultBinds clas ops (FunMonoBind op _ matches loc)
 190   = tcAddSrcLoc loc                                     $
 191
 192         -- Check that the op is from this class
 193     checkTc (op `elem` ops) (badMethodErr clas op)              `thenTc_`
 194
 195         -- Check that all the defns ar generic, or none are
 196     checkTc (all_generic || none_generic) (mixedGenericErr op)  `thenTc_`
 197
 198     returnTc (unitNameEnv op all_generic)
 199   where
 200     n_generic    = count (maybeToBool . maybeGenericMatch) matches
 201     none_generic = n_generic == 0
 202     all_generic  = n_generic == length matches
 203
 204 checkGenericClassIsUnary clas dm_env
 205   = -- Check that if the class has generic methods, then the
 206     -- class has only one parameter.  We can't do generic
 207     -- multi-parameter type classes!
 208     checkTc (unary || no_generics) (genericMultiParamErr clas)
 209   where
 210     unary       = length (classTyVars clas) == 1
 211     no_generics = not (or (nameEnvElts dm_env))
 212 \end{code}
 213
 214
 215 \begin{code}
 216 tcSuperClasses :: RecFlag -> Bool -> Class
 217                -> RenamedContext        -- class context
 218                -> [Name]                -- Names for superclass selectors
 219                -> TcM (ClassContext,    -- the superclass context
 220                          [Id])          -- superclass selector Ids
 221
 222 tcSuperClasses is_rec gla_exts clas context sc_sel_names
 223   =     -- Check the context.
 224         -- The renamer has already checked that the context mentions
 225         -- only the type variable of the class decl.
 226
 227         -- For std Haskell check that the context constrains only tyvars
 228     (if gla_exts then
 229         returnTc ()
 230      else
 231         mapTc_ check_constraint context
 232     )                                           `thenTc_`
 233
 234         -- Context is already kind-checked
 235     tcRecClassContext is_rec context            `thenTc` \ sc_theta ->
 236     let
 237        sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
 238     in
 239         -- Done
 240     returnTc (sc_theta, sc_sel_ids)
 241
 242   where
 243     check_constraint sc@(HsPClass c tys)
 244         = checkTc (all is_tyvar tys) (superClassErr clas sc)
 245
 246     is_tyvar (HsTyVar _) = True
 247     is_tyvar other       = False
 248
 249
 250 tcClassSig :: RecFlag -> RecTcEnv       -- Knot tying only!
 251            -> Class                     -- ...ditto...
 252            -> [TyVar]                   -- The class type variable, used for error check only
 253            -> Maybe (NameEnv Bool)      -- Info about default methods
 254            -> RenamedClassOpSig
 255            -> TcM (Type,                -- Type of the method
 256                      ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
 257
 258 -- This warrants an explanation: we need to separate generic
 259 -- default methods and default methods later on in the compiler
 260 -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
 261 -- Class.DefMeth data structure.
 262
 263 tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
 264            (ClassOpSig op_name sig_dm op_ty src_loc)
 265   = tcAddSrcLoc src_loc $
 266
 267         -- Check the type signature.  NB that the envt *already has*
 268         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 269
 270     tcHsRecType is_rec op_ty                            `thenTc` \ local_ty ->
 271
 272         -- Check for ambiguous class op types
 273     let
 274         theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
 275     in
 276     checkAmbiguity is_rec True clas_tyvars theta local_ty        `thenTc` \ global_ty ->
 277           -- The default method's type should really come from the
 278           -- iface file, since it could be usage-generalised, but this
 279           -- requires altering the mess of knots in TcModule and I'm
 280           -- too scared to do that.  Instead, I have disabled generalisation
 281           -- of types of default methods (and dict funs) by annotating them
 282           -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
 283
 284     let
 285         -- Build the selector id and default method id
 286         sel_id = mkDictSelId op_name clas
 287         dm_id  = mkDefaultMethodId dm_name clas global_ty
 288         DefMeth dm_name = sig_dm
 289
 290         dm_info = case maybe_dm_env of
 291                     Nothing      -> iface_dm_info
 292                     Just dm_env -> mk_src_dm_info dm_env
 293
 294         iface_dm_info = case sig_dm of
 295                           NoDefMeth       -> NoDefMeth
 296                           GenDefMeth      -> GenDefMeth
 297                           DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id)
 298
 299         mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
 300                                    Nothing    -> NoDefMeth
 301                                    Just True  -> GenDefMeth
 302                                    Just False -> DefMeth dm_id
 303     in
 304         -- Check that for a generic method, the type of
 305         -- the method is sufficiently simple
 306     checkTc (dm_info /= GenDefMeth || validGenericMethodType local_ty)
 307             (badGenericMethodType op_name op_ty)                `thenTc_`
 308
 309     returnTc (local_ty, (sel_id, dm_info))
 310 \end{code}
 311
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection[Default methods]{Default methods}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 The default methods for a class are each passed a dictionary for the
 320 class, so that they get access to the other methods at the same type.
 321 So, given the class decl
 322 \begin{verbatim}
 323 class Foo a where
 324         op1 :: a -> Bool
 325         op2 :: Ord b => a -> b -> b -> b
 326
 327         op1 x = True
 328         op2 x y z = if (op1 x) && (y < z) then y else z
 329 \end{verbatim}
 330 we get the default methods:
 331 \begin{verbatim}
 332 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 333 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 334
 335 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 336 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 337                   if (op1 a dfoo x) && (< b dord y z) then y else z
 338 \end{verbatim}
 339
 340 When we come across an instance decl, we may need to use the default
 341 methods:
 342 \begin{verbatim}
 343 instance Foo Int where {}
 344 \end{verbatim}
 345 gives
 346 \begin{verbatim}
 347 const.Foo.Int.op1 :: Int -> Bool
 348 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 349
 350 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 351 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 352
 353 dfun.Foo.Int :: Foo Int
 354 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 355 \end{verbatim}
 356 Notice that, as with method selectors above, we assume that dictionary
 357 application is curried, so there's no need to mention the Ord dictionary
 358 in const.Foo.Int.op2 (or the type variable).
 359
 360 \begin{verbatim}
 361 instance Foo a => Foo [a] where {}
 362
 363 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 364 dfun.Foo.List
 365   = /\ a -> \ dfoo_a ->
 366     let rec
 367         op1 = defm.Foo.op1 [a] dfoo_list
 368         op2 = defm.Foo.op2 [a] dfoo_list
 369         dfoo_list = (op1, op2)
 370     in
 371         dfoo_list
 372 \end{verbatim}
 373
 374 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 375 each local class decl.
 376
 377 \begin{code}
 378 tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds)
 379
 380 tcClassDecls2 this_mod decls
 381   = foldr combine
 382           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 383           [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls]
 384                 -- The 'Just' picks out source ClassDecls
 385   where
 386     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 387                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 388                       returnNF_Tc (lie1 `plusLIE` lie2,
 389                                    binds1 `AndMonoBinds` binds2)
 390 \end{code}
 391
 392 @tcClassDecl2@ generates bindings for polymorphic default methods
 393 (generic default methods have by now turned into instance declarations)
 394
 395 \begin{code}
 396 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 397              -> NF_TcM (LIE, TcMonoBinds)
 398
 399 tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs,
 400                          tcdMeths = Just default_binds, tcdLoc = src_loc})
 401   =     -- The 'Just' picks out source ClassDecls
 402     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 403     tcAddSrcLoc src_loc                                   $
 404     tcLookupClass class_name                              `thenNF_Tc` \ clas ->
 405
 406         -- We make a separate binding for each default method.
 407         -- At one time I used a single AbsBinds for all of them, thus
 408         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 409         -- But that desugars into
 410         --      ds = \d -> (..., ..., ...)
 411         --      dm1 = \d -> case ds d of (a,b,c) -> a
 412         -- And since ds is big, it doesn't get inlined, so we don't get good
 413         -- default methods.  Better to make separate AbsBinds for each
 414     let
 415         (tyvars, _, _, op_items) = classBigSig clas
 416         prags                    = filter isPragSig sigs
 417         tc_dm                    = tcDefMeth clas tyvars default_binds prags
 418     in
 419     mapAndUnzipTc tc_dm op_items        `thenTc` \ (defm_binds, const_lies) ->
 420
 421     returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
 422
 423
 424 tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnTc (EmptyMonoBinds, emptyLIE)
 425 tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE)
 426         -- Generate code for polymorphic default methods only
 427         -- (Generic default methods have turned into instance decls by now.)
 428         -- This is incompatible with Hugs, which expects a polymorphic
 429         -- default method for every class op, regardless of whether or not
 430         -- the programmer supplied an explicit default decl for the class.
 431         -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 432
 433 tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
 434   = tcInstTyVars tyvars                 `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
 435     let
 436         theta = [(mkClassPred clas inst_tys)]
 437     in
 438     newDicts origin theta               `thenNF_Tc` \ [this_dict] ->
 439
 440     tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 441         tcMethodBind clas origin clas_tyvars inst_tys theta
 442                      binds_in prags False op_item
 443     )                                   `thenTc` \ (defm_bind, insts_needed, local_dm_inst) ->
 444
 445     tcAddErrCtxt (defltMethCtxt clas) $
 446
 447         -- Check the context
 448     tcSimplifyCheck
 449         (ptext SLIT("class") <+> ppr clas)
 450         clas_tyvars
 451         [this_dict]
 452         insts_needed                            `thenTc` \ (const_lie, dict_binds) ->
 453
 454         -- Simplification can do unification
 455     checkSigTyVars clas_tyvars emptyVarSet      `thenTc` \ clas_tyvars' ->
 456
 457     let
 458         full_bind = AbsBinds
 459                     clas_tyvars'
 460                     [instToId this_dict]
 461                     [(clas_tyvars', dm_id, instToId local_dm_inst)]
 462                     emptyNameSet        -- No inlines (yet)
 463                     (dict_binds `andMonoBinds` defm_bind)
 464     in
 465     returnTc (full_bind, const_lie)
 466   where
 467     origin = ClassDeclOrigin
 468 \end{code}
 469
 470
 471
 472 %************************************************************************
 473 %*                                                                      *
 474 \subsection{Typechecking a method}
 475 %*                                                                      *
 476 %************************************************************************
 477
 478 @tcMethodBind@ is used to type-check both default-method and
 479 instance-decl method declarations.  We must type-check methods one at a
 480 time, because their signatures may have different contexts and
 481 tyvar sets.
 482
 483 \begin{code}
 484 tcMethodBind
 485         :: Class
 486         -> InstOrigin
 487         -> [TcTyVar]            -- Instantiated type variables for the
 488                                 --  enclosing class/instance decl.
 489                                 --  They'll be signature tyvars, and we
 490                                 --  want to check that they don't get bound
 491         -> [TcType]             -- Instance types
 492         -> TcThetaType          -- Available theta; this could be used to check
 493                                 --  the method signature, but actually that's done by
 494                                 --  the caller;  here, it's just used for the error message
 495         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 496         -> [RenamedSig]         -- Pramgas (just for this one)
 497         -> Bool                 -- True <=> This method is from an instance declaration
 498         -> ClassOpItem          -- The method selector and default-method Id
 499         -> TcM (TcMonoBinds, LIE, Inst)
 500
 501 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 502              meth_binds prags is_inst_decl (sel_id, dm_info)
 503   = tcGetSrcLoc                         `thenNF_Tc` \ loc ->
 504     newMethod origin sel_id inst_tys    `thenNF_Tc` \ meth ->
 505     let
 506         meth_id    = instToId meth
 507         meth_name  = idName meth_id
 508         sig_msg    = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id
 509         meth_prags = find_prags (idName sel_id) meth_name prags
 510     in
 511     mkTcSig meth_id loc                 `thenNF_Tc` \ sig_info ->
 512
 513         -- Figure out what method binding to use
 514         -- If the user suppplied one, use it, else construct a default one
 515     (case find_bind (idName sel_id) meth_name meth_binds of
 516         Just user_bind -> returnTc user_bind
 517         Nothing        -> mkDefMethRhs is_inst_decl clas inst_tys sel_id loc dm_info    `thenTc` \ rhs ->
 518                           returnTc (FunMonoBind meth_name False -- Not infix decl
 519                                                 [mkSimpleMatch [] rhs Nothing loc] loc)
 520     )                                                           `thenTc` \ meth_bind ->
 521      -- Check the bindings; first add inst_tyvars to the envt
 522      -- so that we don't quantify over them in nested places
 523      -- The *caller* put the class/inst decl tyvars into the envt
 524      tcExtendGlobalTyVars (mkVarSet inst_tyvars)
 525                     (tcAddErrCtxt (methodCtxt sel_id)           $
 526                      tcBindWithSigs NotTopLevel meth_bind
 527                      [sig_info] meth_prags NonRecursive
 528                     )                                           `thenTc` \ (binds, insts, _) ->
 529
 530      tcExtendLocalValEnv [(meth_name, meth_id)]
 531                          (tcSpecSigs meth_prags)                `thenTc` \ (prag_binds1, prag_lie) ->
 532
 533      -- The prag_lie for a SPECIALISE pragma will mention the function
 534      -- itself, so we have to simplify them away right now lest they float
 535      -- outwards!
 536      bindInstsOfLocalFuns prag_lie [meth_id]    `thenTc` \ (prag_lie', prag_binds2) ->
 537
 538      -- Now check that the instance type variables
 539      -- (or, in the case of a class decl, the class tyvars)
 540      -- have not been unified with anything in the environment
 541      --
 542      -- We do this for each method independently to localise error messages
 543      -- ...and this is why the call to tcExtendGlobalTyVars must be here
 544      --    rather than in the caller
 545      tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id))    $
 546      checkSigTyVars inst_tyvars emptyVarSet                                     `thenTc_`
 547
 548      returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 549                insts `plusLIE` prag_lie',
 550                meth)
 551
 552      -- The user didn't supply a method binding,
 553      -- so we have to make up a default binding
 554      -- The RHS of a default method depends on the default-method info
 555 mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id)
 556   =  -- An polymorphic default method
 557     returnTc (HsVar (idName dm_id))
 558
 559 mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
 560   =     -- No default method
 561         -- Warn only if -fwarn-missing-methods
 562     doptsTc Opt_WarnMissingMethods  `thenNF_Tc` \ warn ->
 563     warnTc (is_inst_decl && warn)
 564            (omittedMethodWarn sel_id clas)              `thenNF_Tc_`
 565     returnTc error_rhs
 566   where
 567     error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 568                           (HsLit (HsString (_PK_ error_msg)))
 569     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 570
 571
 572 mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth
 573   =     -- A generic default method
 574         -- If the method is defined generically, we can only do the job if the
 575         -- instance declaration is for a single-parameter type class with
 576         -- a type constructor applied to type arguments in the instance decl
 577         --      (checkTc, so False provokes the error)
 578      checkTc (not is_inst_decl || simple_inst)
 579              (badGenericInstance sel_id clas)                   `thenTc_`
 580
 581      ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)  `thenNF_Tc_`
 582      returnTc rhs
 583   where
 584     rhs = mkGenericRhs sel_id clas_tyvar tycon
 585
 586     stuff = vcat [ppr clas <+> ppr inst_tys,
 587                   nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
 588
 589           -- The tycon is only used in the generic case, and in that
 590           -- case we require that the instance decl is for a single-parameter
 591           -- type class with type variable arguments:
 592           --    instance (...) => C (T a b)
 593     simple_inst   = maybeToBool maybe_tycon
 594     clas_tyvar    = head (classTyVars clas)
 595     Just tycon    = maybe_tycon
 596     maybe_tycon   = case inst_tys of
 597                         [ty] -> case splitTyConApp_maybe ty of
 598                                   Just (tycon, arg_tys) | all isTyVarTy arg_tys -> Just tycon
 599                                   other                                         -> Nothing
 600                         other -> Nothing
 601 \end{code}
 602
 603
 604 \begin{code}
 605 -- The renamer just puts the selector ID as the binder in the method binding
 606 -- but we must use the method name; so we substitute it here.  Crude but simple.
 607 find_bind sel_name meth_name (FunMonoBind op_name fix matches loc)
 608     | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
 609 find_bind sel_name meth_name (AndMonoBinds b1 b2)
 610     = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2
 611 find_bind sel_name meth_name other  = Nothing   -- Default case
 612
 613  -- Find the prags for this method, and replace the
 614  -- selector name with the method name
 615 find_prags sel_name meth_name [] = []
 616 find_prags sel_name meth_name (SpecSig name ty loc : prags)
 617      | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags
 618 find_prags sel_name meth_name (InlineSig name phase loc : prags)
 619    | name == sel_name = InlineSig meth_name phase loc : find_prags sel_name meth_name prags
 620 find_prags sel_name meth_name (NoInlineSig name phase loc : prags)
 621    | name == sel_name = NoInlineSig meth_name phase loc : find_prags sel_name meth_name prags
 622 find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
 623 \end{code}
 624
 625
 626 Contexts and errors
 627 ~~~~~~~~~~~~~~~~~~~
 628 \begin{code}
 629 classArityErr class_name
 630   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 631
 632 superClassErr clas sc
 633   = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
 634     <+> ptext SLIT("in declaration for class") <+> quotes (ppr clas)
 635
 636 defltMethCtxt clas
 637   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 638
 639 methodCtxt sel_id
 640   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 641
 642 badMethodErr clas op
 643   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 644           ptext SLIT("does not have a method"), quotes (ppr op)]
 645
 646 omittedMethodWarn sel_id clas
 647   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 648          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 649
 650 badGenericMethodType op op_ty
 651   = hang (ptext SLIT("Generic method type is too complex"))
 652        4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 653                 ptext SLIT("You can only use type variables, arrows, and tuples")])
 654
 655 badGenericInstance sel_id clas
 656   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 657          ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
 658          ptext SLIT("(where T is a derivable type constructor)"),
 659          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 660
 661 mixedGenericErr op
 662   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 663
 664 genericMultiParamErr clas
 665   = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+>
 666     ptext SLIT("cannot have generic methods")
 667 \end{code}