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