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