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 ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
   8                     tcMethodBind, checkFromThisClass
   9                   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
  14                           InPat(..), HsBinds(..), GRHSs(..),
  15                           HsExpr(..), HsLit(..), HsType(..), HsPred(..),
  16                           pprHsClassAssertion, unguardedRHS,
  17                           andMonoBinds, andMonoBindList, getTyVarName,
  18                           isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
  19                         )
  20 import HsPragmas        ( ClassPragmas(..) )
  21 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
  22 import RnHsSyn          ( RenamedTyClDecl, RenamedClassPragmas,
  23                           RenamedClassOpSig, RenamedMonoBinds,
  24                           RenamedContext, RenamedHsDecl, RenamedSig
  25                         )
  26 import TcHsSyn          ( TcMonoBinds, idsToMonoBinds )
  27
  28 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
  29 import TcEnv            ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
  30                           tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
  31                           tcExtendLocalValEnv
  32                         )
  33 import TcBinds          ( tcBindWithSigs, tcSpecSigs )
  34 import TcUnify          ( unifyKinds )
  35 import TcMonad
  36 import TcMonoType       ( kcHsType, tcHsTopType, tcExtendTopTyVarScope,
  37                           tcContext, checkSigTyVars, sigCtxt, mkTcSig
  38                         )
  39 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  40 import TcType           ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
  41 import TcInstUtil       ( classDataCon )
  42 import PrelInfo         ( nO_METHOD_BINDING_ERROR_ID )
  43 import FieldLabel       ( firstFieldLabelTag )
  44 import Bag              ( unionManyBags, bagToList )
  45 import Class            ( mkClass, classBigSig, classSelIds, Class, ClassOpItem )
  46 import CmdLineOpts      ( opt_GlasgowExts, opt_WarnMissingMethods )
  47 import MkId             ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
  48 import DataCon          ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict )
  49 import Id               ( Id, setInlinePragma, idUnfolding, idType, idName )
  50 import CoreUnfold       ( unfoldingTemplate )
  51 import IdInfo
  52 import Name             ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
  53 import NameSet          ( emptyNameSet )
  54 import Outputable
  55 import Type             ( Type, ThetaType, ClassContext,
  56                           mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
  57                           mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
  58                           boxedTypeKind, mkArrowKind
  59                         )
  60 import Var              ( tyVarKind, TyVar )
  61 import VarSet           ( mkVarSet, emptyVarSet )
  62 import TyCon            ( mkAlgTyCon )
  63 import Unique           ( Unique, Uniquable(..) )
  64 import Util
  65 import Maybes           ( seqMaybe )
  66 import FiniteMap        ( lookupWithDefaultFM )
  67 \end{code}
  68
  69
  70
  71 Dictionary handling
  72 ~~~~~~~~~~~~~~~~~~~
  73 Every class implicitly declares a new data type, corresponding to dictionaries
  74 of that class. So, for example:
  75
  76         class (D a) => C a where
  77           op1 :: a -> a
  78           op2 :: forall b. Ord b => a -> b -> b
  79
  80 would implicitly declare
  81
  82         data CDict a = CDict (D a)
  83                              (a -> a)
  84                              (forall b. Ord b => a -> b -> b)
  85
  86 (We could use a record decl, but that means changing more of the existing apparatus.
  87 One step at at time!)
  88
  89 For classes with just one superclass+method, we use a newtype decl instead:
  90
  91         class C a where
  92           op :: forallb. a -> b -> b
  93
  94 generates
  95
  96         newtype CDict a = CDict (forall b. a -> b -> b)
  97
  98 Now DictTy in Type is just a form of type synomym:
  99         DictTy c t = TyConTy CDict `AppTy` t
 100
 101 Death to "ExpandingDicts".
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{Kind checking}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 kcClassDecl (ClassDecl  context class_name
 112                         tyvar_names fundeps class_sigs def_methods pragmas
 113                         _ _ _ _ src_loc)
 114   =         -- CHECK ARITY 1 FOR HASKELL 1.4
 115     checkTc (opt_GlasgowExts || length tyvar_names == 1)
 116             (classArityErr class_name)          `thenTc_`
 117
 118         -- Get the (mutable) class kind
 119     tcLookupTy class_name                       `thenNF_Tc` \ (kind, _, _) ->
 120
 121         -- Make suitable tyvars and do kind checking
 122         -- The net effect is to mutate the class kind
 123     tcExtendTopTyVarScope kind tyvar_names      $ \ _ _ ->
 124     tcContext context                           `thenTc_`
 125     mapTc kc_sig the_class_sigs                 `thenTc_`
 126
 127     returnTc ()
 128   where
 129     the_class_sigs = filter isClassOpSig class_sigs
 130
 131     kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty)
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{Type checking}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
 143              (ClassDecl context class_name
 144                         tyvar_names fundeps class_sigs def_methods pragmas
 145                         tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
 146   =     -- LOOK THINGS UP IN THE ENVIRONMENT
 147     tcLookupTy class_name                               `thenTc` \ (class_kind, _, AClass rec_class) ->
 148     tcExtendTopTyVarScope class_kind tyvar_names        $ \ tyvars _ ->
 149         -- The class kind is by now immutable
 150
 151         -- CHECK THE CONTEXT
 152 --  traceTc (text "tcClassCtxt" <+> ppr class_name)     `thenTc_`
 153     tcClassContext class_name rec_class tyvars context sc_sel_names
 154                                                 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 155 --  traceTc (text "tcClassCtxt done" <+> ppr class_name)        `thenTc_`
 156
 157         -- CHECK THE FUNCTIONAL DEPENDENCIES,
 158     tcFundeps fundeps                           `thenTc` \ fds ->
 159
 160         -- CHECK THE CLASS SIGNATURES,
 161     mapTc (tcClassSig rec_env rec_class tyvars)
 162           (filter isClassOpSig class_sigs)
 163                                                 `thenTc` \ sig_stuff ->
 164
 165         -- MAKE THE CLASS OBJECT ITSELF
 166     let
 167         (op_tys, op_items) = unzip sig_stuff
 168         rec_class_inst_env = rec_inst_mapper rec_class
 169         clas = mkClass class_name tyvars fds
 170                        sc_theta sc_sel_ids op_items
 171                        tycon
 172                        rec_class_inst_env
 173
 174         dict_component_tys = sc_tys ++ op_tys
 175         new_or_data = case dict_component_tys of
 176                         [_]   -> NewType
 177                         other -> DataType
 178
 179         dict_con = mkDataCon datacon_name
 180                            [notMarkedStrict | _ <- dict_component_tys]
 181                            [{- No labelled fields -}]
 182                            tyvars
 183                            [{-No context-}]
 184                            [{-No existential tyvars-}] [{-Or context-}]
 185                            dict_component_tys
 186                            tycon dict_con_id dict_wrap_id
 187
 188         dict_con_id  = mkDataConId datacon_wkr_name dict_con
 189         dict_wrap_id = mkDataConWrapId dict_con
 190
 191         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
 192                                                          ppr tycon_name)
 193                                       tycon_name
 194
 195         tycon = mkAlgTyCon tycon_name
 196                             class_kind
 197                             tyvars
 198                             []                  -- No context
 199                             argvrcs
 200                             [dict_con]          -- Constructors
 201                             []                  -- No derivings
 202                             (Just clas)         -- Yes!  It's a dictionary
 203                             new_or_data
 204                             NonRecursive
 205     in
 206     returnTc clas
 207 \end{code}
 208
 209 \begin{code}
 210 tcFundeps = mapTc tc_fundep
 211 tc_fundep (us, vs) =
 212     mapTc tc_fd_tyvar us        `thenTc` \ us' ->
 213     mapTc tc_fd_tyvar vs        `thenTc` \ vs' ->
 214     returnTc (us', vs')
 215 tc_fd_tyvar v =
 216     tcLookupTy v `thenTc` \(_, _, thing) ->
 217     case thing of
 218         ATyVar tv -> returnTc tv
 219         -- ZZ else should fail more gracefully
 220 \end{code}
 221
 222 \begin{code}
 223 tcClassContext :: Name -> Class -> [TyVar]
 224                -> RenamedContext        -- class context
 225                -> [Name]                -- Names for superclass selectors
 226                -> TcM s (ClassContext,  -- the superclass context
 227                          [Type],        -- types of the superclass dictionaries
 228                          [Id])          -- superclass selector Ids
 229
 230 tcClassContext class_name rec_class rec_tyvars context sc_sel_names
 231   =     -- Check the context.
 232         -- The renamer has already checked that the context mentions
 233         -- only the type variable of the class decl.
 234
 235         -- For std Haskell check that the context constrains only tyvars
 236     (if opt_GlasgowExts then
 237         returnTc []
 238      else
 239         mapTc check_constraint context
 240     )                                   `thenTc_`
 241
 242     tcContext context                   `thenTc` \ sc_theta ->
 243
 244     let
 245        sc_theta' = classesOfPreds sc_theta
 246        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
 247        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
 248     in
 249         -- Done
 250     returnTc (sc_theta', sc_tys, sc_sel_ids)
 251
 252   where
 253     rec_tyvar_tys = mkTyVarTys rec_tyvars
 254
 255     mk_super_id name dict_ty
 256         = mkDictSelId name rec_class ty
 257         where
 258           ty = mkForAllTys rec_tyvars $
 259                mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
 260
 261     check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
 262                                          (superClassErr class_name (c, tys))
 263
 264     is_tyvar (MonoTyVar _) = True
 265     is_tyvar other         = False
 266
 267
 268 tcClassSig :: ValueEnv          -- Knot tying only!
 269            -> Class                     -- ...ditto...
 270            -> [TyVar]                   -- The class type variable, used for error check only
 271            -> RenamedClassOpSig
 272            -> TcM s (Type,              -- Type of the method
 273                      ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
 274
 275
 276 tcClassSig rec_env rec_clas rec_clas_tyvars
 277            (ClassOpSig op_name dm_name explicit_dm
 278                        op_ty src_loc)
 279   = tcAddSrcLoc src_loc $
 280
 281         -- Check the type signature.  NB that the envt *already has*
 282         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 283
 284     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 285     -- and that it is not constrained by theta
 286 --  traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
 287     tcHsTopType op_ty                           `thenTc` \ local_ty ->
 288     let
 289         global_ty   = mkSigmaTy rec_clas_tyvars
 290                                 [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)]
 291                                 local_ty
 292
 293         -- Build the selector id and default method id
 294         sel_id      = mkDictSelId op_name rec_clas global_ty
 295         dm_id       = mkDefaultMethodId dm_name rec_clas global_ty
 296         final_dm_id = tcAddImportedIdInfo rec_env dm_id
 297     in
 298 --  traceTc (text "tcClassSig done" <+> ppr op_name)    `thenTc_`
 299     returnTc (local_ty, (sel_id, final_dm_id, explicit_dm))
 300 \end{code}
 301
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 The purpose of pass 2 is
 310 \begin{enumerate}
 311 \item
 312 to beat on the explicitly-provided default-method decls (if any),
 313 using them to produce a complete set of default-method decls.
 314 (Omitted ones elicit an error message.)
 315 \item
 316 to produce a definition for the selector function for each method
 317 and superclass dictionary.
 318 \end{enumerate}
 319
 320 Pass~2 only applies to locally-defined class declarations.
 321
 322 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 323 each local class decl.
 324
 325 \begin{code}
 326 tcClassDecls2 :: [RenamedHsDecl]
 327               -> NF_TcM s (LIE, TcMonoBinds)
 328
 329 tcClassDecls2 decls
 330   = foldr combine
 331           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 332           [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
 333   where
 334     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 335                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 336                       returnNF_Tc (lie1 `plusLIE` lie2,
 337                                    binds1 `AndMonoBinds` binds2)
 338 \end{code}
 339
 340 @tcClassDecl2@ is the business end of things.
 341
 342 \begin{code}
 343 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 344              -> NF_TcM s (LIE, TcMonoBinds)
 345
 346 tcClassDecl2 (ClassDecl context class_name
 347                         tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc)
 348
 349   | not (isLocallyDefined class_name)
 350   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 351
 352   | otherwise   -- It is locally defined
 353   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 354     tcAddSrcLoc src_loc                                   $
 355     tcLookupClass class_name                            `thenNF_Tc` \ clas ->
 356     tcDefaultMethodBinds clas default_binds class_sigs
 357 \end{code}
 358
 359 \begin{code}
 360 mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds)
 361 mkImplicitClassBinds classes
 362   = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
 363         -- The selector binds are already in the selector Id's unfoldings
 364   where
 365     (cls_ids_s, binds_s) = unzip (map mk_implicit classes)
 366
 367     mk_implicit clas = (all_cls_ids, binds)
 368                      where
 369                         dict_con    = classDataCon clas
 370                         all_cls_ids = dataConId dict_con : cls_ids
 371                         cls_ids     = dataConWrapId dict_con : classSelIds clas
 372
 373                         -- The wrapper and selectors get bindings, the worker does not
 374                         binds | isLocallyDefined clas = idsToMonoBinds cls_ids
 375                               | otherwise             = EmptyMonoBinds
 376 \end{code}
 377
 378 %************************************************************************
 379 %*                                                                      *
 380 \subsection[Default methods]{Default methods}
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 The default methods for a class are each passed a dictionary for the
 385 class, so that they get access to the other methods at the same type.
 386 So, given the class decl
 387 \begin{verbatim}
 388 class Foo a where
 389         op1 :: a -> Bool
 390         op2 :: Ord b => a -> b -> b -> b
 391
 392         op1 x = True
 393         op2 x y z = if (op1 x) && (y < z) then y else z
 394 \end{verbatim}
 395 we get the default methods:
 396 \begin{verbatim}
 397 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 398 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 399
 400 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 401 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 402                   if (op1 a dfoo x) && (< b dord y z) then y else z
 403 \end{verbatim}
 404
 405 When we come across an instance decl, we may need to use the default
 406 methods:
 407 \begin{verbatim}
 408 instance Foo Int where {}
 409 \end{verbatim}
 410 gives
 411 \begin{verbatim}
 412 const.Foo.Int.op1 :: Int -> Bool
 413 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 414
 415 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 416 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 417
 418 dfun.Foo.Int :: Foo Int
 419 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 420 \end{verbatim}
 421 Notice that, as with method selectors above, we assume that dictionary
 422 application is curried, so there's no need to mention the Ord dictionary
 423 in const.Foo.Int.op2 (or the type variable).
 424
 425 \begin{verbatim}
 426 instance Foo a => Foo [a] where {}
 427
 428 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 429 dfun.Foo.List
 430   = /\ a -> \ dfoo_a ->
 431     let rec
 432         op1 = defm.Foo.op1 [a] dfoo_list
 433         op2 = defm.Foo.op2 [a] dfoo_list
 434         dfoo_list = (op1, op2)
 435     in
 436         dfoo_list
 437 \end{verbatim}
 438
 439 \begin{code}
 440 tcDefaultMethodBinds
 441         :: Class
 442         -> RenamedMonoBinds
 443         -> [RenamedSig]
 444         -> TcM s (LIE, TcMonoBinds)
 445
 446 tcDefaultMethodBinds clas default_binds sigs
 447   =     -- Check that the default bindings come from this class
 448     checkFromThisClass clas op_items default_binds      `thenNF_Tc_`
 449
 450         -- Do each default method separately
 451         -- For Hugs compatibility we make a default-method for every
 452         -- class op, regardless of whether or not the programmer supplied an
 453         -- explicit default decl for the class.  GHC will actually never
 454         -- call the default method for such operations, because it'll whip up
 455         -- a more-informative default method at each instance decl.
 456     mapAndUnzipTc tc_dm op_items                `thenTc` \ (defm_binds, const_lies) ->
 457
 458     returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
 459   where
 460     prags = filter isPragSig sigs
 461
 462     (tyvars, _, _, op_items) = classBigSig clas
 463
 464     origin = ClassDeclOrigin
 465
 466     -- We make a separate binding for each default method.
 467     -- At one time I used a single AbsBinds for all of them, thus
 468     --  AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 469     -- But that desugars into
 470     --  ds = \d -> (..., ..., ...)
 471     --  dm1 = \d -> case ds d of (a,b,c) -> a
 472     -- And since ds is big, it doesn't get inlined, so we don't get good
 473     -- default methods.  Better to make separate AbsBinds for each
 474
 475     tc_dm op_item@(_, dm_id, _)
 476       = tcInstTyVars tyvars             `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
 477         let
 478             theta = [(mkClassPred clas inst_tys)]
 479         in
 480         newDicts origin theta                   `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 481         let
 482             avail_insts = this_dict
 483         in
 484         tcExtendTyVarEnvForMeths tyvars clas_tyvars (
 485             tcMethodBind clas origin clas_tyvars inst_tys theta
 486                          default_binds prags False
 487                          op_item
 488         )                                       `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
 489
 490         tcAddErrCtxt (defltMethCtxt clas) $
 491
 492             -- tcMethodBind has checked that the class_tyvars havn't
 493             -- been unified with each other or another type, but we must
 494             -- still zonk them before passing them to tcSimplifyAndCheck
 495         mapNF_Tc zonkTcTyVarBndr clas_tyvars    `thenNF_Tc` \ clas_tyvars' ->
 496
 497             -- Check the context
 498         tcSimplifyAndCheck
 499             (ptext SLIT("class") <+> ppr clas)
 500             (mkVarSet clas_tyvars')
 501             avail_insts
 502             insts_needed                        `thenTc` \ (const_lie, dict_binds) ->
 503
 504         let
 505             full_bind = AbsBinds
 506                             clas_tyvars'
 507                             [this_dict_id]
 508                             [(clas_tyvars', dm_id, local_dm_id)]
 509                             emptyNameSet        -- No inlines (yet)
 510                             (dict_binds `andMonoBinds` defm_bind)
 511         in
 512         returnTc (full_bind, const_lie)
 513 \end{code}
 514
 515 \begin{code}
 516 checkFromThisClass :: Class -> [ClassOpItem] -> RenamedMonoBinds -> NF_TcM s ()
 517 checkFromThisClass clas op_items mono_binds
 518   = mapNF_Tc check_from_this_class bndrs        `thenNF_Tc_`
 519     returnNF_Tc ()
 520   where
 521     check_from_this_class (bndr, loc)
 522           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 523           | otherwise                         = tcAddSrcLoc loc $
 524                                                 addErrTc (badMethodErr bndr clas)
 525     sel_names = [getOccName sel_id | (sel_id,_,_) <- op_items]
 526     bndrs = bagToList (collectMonoBinders mono_binds)
 527 \end{code}
 528
 529
 530 @tcMethodBind@ is used to type-check both default-method and
 531 instance-decl method declarations.  We must type-check methods one at a
 532 time, because their signatures may have different contexts and
 533 tyvar sets.
 534
 535 \begin{code}
 536 tcMethodBind
 537         :: Class
 538         -> InstOrigin
 539         -> [TcTyVar]            -- Instantiated type variables for the
 540                                 --  enclosing class/instance decl.
 541                                 --  They'll be signature tyvars, and we
 542                                 --  want to check that they don't get bound
 543         -> [TcType]             -- Instance types
 544         -> TcThetaType          -- Available theta; this could be used to check
 545                                 --  the method signature, but actually that's done by
 546                                 --  the caller;  here, it's just used for the error message
 547         -> RenamedMonoBinds     -- Method binding (pick the right one from in here)
 548         -> [RenamedSig]         -- Pramgas (just for this one)
 549         -> Bool                 -- True <=> This method is from an instance declaration
 550         -> ClassOpItem          -- The method selector and default-method Id
 551         -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
 552
 553 tcMethodBind clas origin inst_tyvars inst_tys inst_theta
 554              meth_binds prags is_inst_decl
 555              (sel_id, dm_id, explicit_dm)
 556  = tcGetSrcLoc          `thenNF_Tc` \ loc ->
 557
 558    newMethod origin sel_id inst_tys     `thenNF_Tc` \ meth@(_, meth_id) ->
 559    mkTcSig meth_id loc                  `thenNF_Tc` \ sig_info ->
 560
 561    let
 562      meth_name       = idName meth_id
 563      maybe_user_bind = find_bind meth_name meth_binds
 564
 565      no_user_bind    = case maybe_user_bind of {Nothing -> True; other -> False}
 566
 567      meth_bind = case maybe_user_bind of
 568                         Just bind -> bind
 569                         Nothing   -> mk_default_bind meth_name loc
 570
 571      meth_prags = find_prags meth_name prags
 572    in
 573
 574         -- Warn if no method binding, only if -fwarn-missing-methods
 575    warnTc (is_inst_decl && opt_WarnMissingMethods && no_user_bind && not explicit_dm)
 576           (omittedMethodWarn sel_id clas)               `thenNF_Tc_`
 577
 578         -- Check the bindings; first add inst_tyvars to the envt
 579         -- so that we don't quantify over them in nested places
 580         -- The *caller* put the class/inst decl tyvars into the envt
 581    tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
 582      tcAddErrCtxt (methodCtxt sel_id)           $
 583      tcBindWithSigs NotTopLevel meth_bind
 584                     [sig_info] meth_prags NonRecursive
 585    )                                            `thenTc` \ (binds, insts, _) ->
 586
 587
 588    tcExtendLocalValEnv [(meth_name, meth_id)] (
 589         tcSpecSigs meth_prags
 590    )                                            `thenTc` \ (prag_binds1, prag_lie) ->
 591
 592         -- The prag_lie for a SPECIALISE pragma will mention the function
 593         -- itself, so we have to simplify them away right now lest they float
 594         -- outwards!
 595    bindInstsOfLocalFuns prag_lie [meth_id]      `thenTc` \ (prag_lie', prag_binds2) ->
 596
 597
 598         -- Now check that the instance type variables
 599         -- (or, in the case of a class decl, the class tyvars)
 600         -- have not been unified with anything in the environment
 601    tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id))      $
 602    checkSigTyVars inst_tyvars emptyVarSet                                       `thenTc_`
 603
 604    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
 605              insts `plusLIE` prag_lie',
 606              meth)
 607  where
 608    sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name
 609
 610    sel_name = idName sel_id
 611
 612         -- The renamer just puts the selector ID as the binder in the method binding
 613         -- but we must use the method name; so we substitute it here.  Crude but simple.
 614    find_bind meth_name (FunMonoBind op_name fix matches loc)
 615         | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
 616    find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
 617         | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
 618    find_bind meth_name (AndMonoBinds b1 b2)
 619                               = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
 620    find_bind meth_name other  = Nothing -- Default case
 621
 622
 623         -- Find the prags for this method, and replace the
 624         -- selector name with the method name
 625    find_prags meth_name [] = []
 626    find_prags meth_name (SpecSig name ty loc : prags)
 627         | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags
 628    find_prags meth_name (InlineSig name phase loc : prags)
 629         | name == sel_name = InlineSig meth_name phase loc : find_prags meth_name prags
 630    find_prags meth_name (NoInlineSig name phase loc : prags)
 631         | name == sel_name = NoInlineSig meth_name phase loc : find_prags meth_name prags
 632    find_prags meth_name (prag:prags) = find_prags meth_name prags
 633
 634    mk_default_bind local_meth_name loc
 635       = PatMonoBind (VarPatIn local_meth_name)
 636                     (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
 637                     loc
 638
 639    default_expr loc
 640         | explicit_dm = HsVar (getName dm_id)   -- There's a default method
 641         | otherwise   = error_expr loc          -- No default method
 642
 643    error_expr loc = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 644                           (HsLit (HsString (_PK_ (error_msg loc))))
 645
 646    error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 647 \end{code}
 648
 649 Contexts and errors
 650 ~~~~~~~~~~~~~~~~~~~
 651 \begin{code}
 652 classArityErr class_name
 653   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 654
 655 superClassErr class_name sc
 656   = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
 657     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 658
 659 defltMethCtxt class_name
 660   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
 661
 662 methodCtxt sel_id
 663   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 664
 665 badMethodErr bndr clas
 666   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 667           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 668
 669 omittedMethodWarn sel_id clas
 670   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 671          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 672 \end{code}