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