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