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