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