ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
   8
   9 #include "HsVersions.h"
  10
  11
  12 import CmdLineOpts      ( DynFlag(..) )
  13
  14 import HsSyn            ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
  15                           MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), HsTyVarBndr(..),
  16                           andMonoBindList, collectMonoBinders, isClassDecl, toHsType
  17                         )
  18 import RnHsSyn          ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
  19                           RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
  20                           extractHsTyVars, maybeGenericMatch
  21                         )
  22 import TcHsSyn          ( TcMonoBinds, mkHsConApp )
  23 import TcBinds          ( tcSpecSigs )
  24 import TcClassDcl       ( tcMethodBind, badMethodErr )
  25 import TcMonad
  26 import TcMType          ( tcInstSigTyVars, checkValidTheta, checkValidInstHead, instTypeErr,
  27                           UserTypeCtxt(..), SourceTyCtxt(..) )
  28 import TcType           ( tcSplitDFunTy, mkClassPred, mkTyVarTy, mkTyVarTys,
  29                           tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys,
  30                           TyVarDetails(..)
  31                         )
  32 import Inst             ( InstOrigin(..),
  33                           newDicts, instToId,
  34                           LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
  35 import TcDeriv          ( tcDeriving )
  36 import TcEnv            ( TcEnv, tcExtendGlobalValEnv,
  37                           tcExtendTyVarEnvForMeths,
  38                           tcAddImportedIdInfo, tcLookupClass,
  39                           InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
  40                           simpleInstInfoTy, newDFunName,
  41                           isLocalThing,
  42                         )
  43 import InstEnv          ( InstEnv, extendInstEnv )
  44 import PprType          ( pprClassPred )
  45 import TcMonoType       ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType, checkSigTyVars )
  46 import TcSimplify       ( tcSimplifyCheck )
  47 import HscTypes         ( HomeSymbolTable, DFunId,
  48                           ModDetails(..), PackageInstEnv, PersistentRenamerState
  49                         )
  50
  51 import Subst            ( substTy, substTheta )
  52 import DataCon          ( classDataCon )
  53 import Class            ( Class, DefMeth(..), classBigSig )
  54 import Var              ( idName, idType )
  55 import VarSet           ( emptyVarSet )
  56 import Id               ( setIdLocalExported )
  57 import MkId             ( mkDictFunId )
  58 import FunDeps          ( checkInstFDs )
  59 import Generics         ( validGenericInstanceType )
  60 import Module           ( Module, foldModuleEnv )
  61 import Name             ( getSrcLoc )
  62 import NameSet          ( unitNameSet, emptyNameSet, nameSetToList )
  63 import PrelInfo         ( eRROR_ID )
  64 import TyCon            ( TyCon )
  65 import Subst            ( mkTopTyVarSubst, substTheta )
  66 import TysWiredIn       ( genericTyCons )
  67 import Name             ( Name )
  68 import SrcLoc           ( SrcLoc )
  69 import Unique           ( Uniquable(..) )
  70 import Util             ( lengthExceeds )
  71 import BasicTypes       ( NewOrData(..), Fixity )
  72 import ErrUtils         ( dumpIfSet_dyn )
  73 import ListSetOps       ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
  74                           assocElts, extendAssoc_C,
  75                           equivClassesByUniq, minusList
  76                         )
  77 import List             ( partition )
  78 import Outputable
  79 \end{code}
  80
  81 Typechecking instance declarations is done in two passes. The first
  82 pass, made by @tcInstDecls1@, collects information to be used in the
  83 second pass.
  84
  85 This pre-processed info includes the as-yet-unprocessed bindings
  86 inside the instance declaration.  These are type-checked in the second
  87 pass, when the class-instance envs and GVE contain all the info from
  88 all the instance and value decls.  Indeed that's the reason we need
  89 two passes over the instance decls.
  90
  91
  92 Here is the overall algorithm.
  93 Assume that we have an instance declaration
  94
  95     instance c => k (t tvs) where b
  96
  97 \begin{enumerate}
  98 \item
  99 $LIE_c$ is the LIE for the context of class $c$
 100 \item
 101 $betas_bar$ is the free variables in the class method type, excluding the
 102    class variable
 103 \item
 104 $LIE_cop$ is the LIE constraining a particular class method
 105 \item
 106 $tau_cop$ is the tau type of a class method
 107 \item
 108 $LIE_i$ is the LIE for the context of instance $i$
 109 \item
 110 $X$ is the instance constructor tycon
 111 \item
 112 $gammas_bar$ is the set of type variables of the instance
 113 \item
 114 $LIE_iop$ is the LIE for a particular class method instance
 115 \item
 116 $tau_iop$ is the tau type for this instance of a class method
 117 \item
 118 $alpha$ is the class variable
 119 \item
 120 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 121 \item
 122 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 123 \end{enumerate}
 124
 125 ToDo: Update the list above with names actually in the code.
 126
 127 \begin{enumerate}
 128 \item
 129 First, make the LIEs for the class and instance contexts, which means
 130 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 131 and make LIElistI and LIEI.
 132 \item
 133 Then process each method in turn.
 134 \item
 135 order the instance methods according to the ordering of the class methods
 136 \item
 137 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 138 \item
 139 Create final dictionary function from bindings generated already
 140 \begin{pseudocode}
 141 df = lambda inst_tyvars
 142        lambda LIEI
 143          let Bop1
 144              Bop2
 145              ...
 146              Bopn
 147          and dbinds_super
 148               in <op1,op2,...,opn,sd1,...,sdm>
 149 \end{pseudocode}
 150 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 151 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 152 \end{enumerate}
 153
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection{Extracting instance decls}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 Gather up the instance declarations from their various sources
 162
 163 \begin{code}
 164 tcInstDecls1 :: PackageInstEnv
 165              -> PersistentRenamerState
 166              -> HomeSymbolTable         -- Contains instances
 167              -> TcEnv                   -- Contains IdInfo for dfun ids
 168              -> (Name -> Maybe Fixity)  -- for deriving Show and Read
 169              -> Module                  -- Module for deriving
 170              -> [RenamedHsDecl]
 171              -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
 172
 173 tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
 174   = let
 175         inst_decls = [inst_decl | InstD inst_decl <- decls]
 176         tycl_decls = [decl      | TyClD decl <- decls]
 177         clas_decls = filter isClassDecl tycl_decls
 178     in
 179         -- (1) Do the ordinary instance declarations
 180     mapNF_Tc tcInstDecl1 inst_decls             `thenNF_Tc` \ inst_infos ->
 181
 182         -- (2) Instances from generic class declarations
 183     getGenericInstances clas_decls              `thenTc` \ generic_inst_info ->
 184
 185         -- Next, construct the instance environment so far, consisting of
 186         --      a) cached non-home-package InstEnv (gotten from pcs)    pcs_insts pcs
 187         --      b) imported instance decls (not in the home package)    inst_env1
 188         --      c) other modules in this package (gotten from hst)      inst_env2
 189         --      d) local instance decls                                 inst_env3
 190         --      e) generic instances                                    inst_env4
 191         -- The result of (b) replaces the cached InstEnv in the PCS
 192     let
 193         (local_inst_info, imported_inst_info)
 194                 = partition (isLocalThing this_mod . iDFunId) (concat inst_infos)
 195
 196         imported_dfuns   = map (tcAddImportedIdInfo unf_env . iDFunId)
 197                                imported_inst_info
 198         hst_dfuns        = foldModuleEnv ((++) . md_insts) [] hst
 199     in
 200
 201 --    pprTrace "tcInstDecls" (vcat [ppr imported_dfuns, ppr hst_dfuns]) $
 202
 203     addInstDFuns inst_env0 imported_dfuns       `thenNF_Tc` \ inst_env1 ->
 204     addInstDFuns inst_env1 hst_dfuns            `thenNF_Tc` \ inst_env2 ->
 205     addInstInfos inst_env2 local_inst_info      `thenNF_Tc` \ inst_env3 ->
 206     addInstInfos inst_env3 generic_inst_info    `thenNF_Tc` \ inst_env4 ->
 207
 208         -- (3) Compute instances from "deriving" clauses;
 209         --     note that we only do derivings for things in this module;
 210         --     we ignore deriving decls from interfaces!
 211         -- This stuff computes a context for the derived instance decl, so it
 212         -- needs to know about all the instances possible; hecne inst_env4
 213     tcDeriving prs this_mod inst_env4 get_fixity tycl_decls
 214                                         `thenTc` \ (deriv_inst_info, deriv_binds) ->
 215     addInstInfos inst_env4 deriv_inst_info              `thenNF_Tc` \ final_inst_env ->
 216
 217     returnTc (inst_env1,
 218               final_inst_env,
 219               generic_inst_info ++ deriv_inst_info ++ local_inst_info,
 220               deriv_binds)
 221
 222 addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
 223 addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
 224
 225 addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
 226 addInstDFuns inst_env dfuns
 227   = getDOptsTc                          `thenTc` \ dflags ->
 228     let
 229         (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 230     in
 231     addErrsTc errs                      `thenNF_Tc_`
 232     traceTc (text "Adding instances:" <+> vcat (map pp dfuns))  `thenTc_`
 233     returnTc inst_env'
 234   where
 235     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 236 \end{code}
 237
 238 \begin{code}
 239 tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo]
 240 -- Deal with a single instance declaration
 241 -- Type-check all the stuff before the "where"
 242 tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
 243   =     -- Prime error recovery, set source location
 244     recoverNF_Tc (returnNF_Tc [])       $
 245     tcAddSrcLoc src_loc                 $
 246     tcAddErrCtxt (instDeclCtxt poly_ty) $
 247
 248         -- Typecheck the instance type itself.  We can't use
 249         -- tcHsSigType, because it's not a valid user type.
 250     kcHsSigType poly_ty                 `thenTc_`
 251     tcHsType poly_ty                    `thenTc` \ poly_ty' ->
 252     let
 253         (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
 254         (clas,inst_tys)      = case tcSplitPredTy_maybe tau of { Just st -> getClassPredTys st }
 255                 -- The checkValidInstHead makes sure these splits succeed
 256     in
 257     (case maybe_dfun_name of
 258         Nothing ->      -- A source-file instance declaration
 259                 -- Check for respectable instance type, and context
 260                 -- but only do this for non-imported instance decls.
 261                 -- Imported ones should have been checked already, and may indeed
 262                 -- contain something illegal in normal Haskell, notably
 263                 --      instance CCallable [Char]
 264             checkValidTheta InstThetaCtxt theta         `thenTc_`
 265             checkValidInstHead tau                      `thenTc_`
 266             checkTc (checkInstFDs theta clas inst_tys)
 267                     (instTypeErr (pprClassPred clas inst_tys) msg)      `thenTc_`
 268             newDFunName clas inst_tys src_loc
 269
 270         Just dfun_name ->       -- An interface-file instance declaration
 271                             returnNF_Tc dfun_name
 272     )                                                           `thenNF_Tc` \ dfun_name ->
 273     let
 274         dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
 275     in
 276     returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }]
 277   where
 278     msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
 279 \end{code}
 280
 281
 282 %************************************************************************
 283 %*                                                                      *
 284 \subsection{Extracting generic instance declaration from class declarations}
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 @getGenericInstances@ extracts the generic instance declarations from a class
 289 declaration.  For exmaple
 290
 291         class C a where
 292           op :: a -> a
 293
 294           op{ x+y } (Inl v)   = ...
 295           op{ x+y } (Inr v)   = ...
 296           op{ x*y } (v :*: w) = ...
 297           op{ 1   } Unit      = ...
 298
 299 gives rise to the instance declarations
 300
 301         instance C (x+y) where
 302           op (Inl v)   = ...
 303           op (Inr v)   = ...
 304
 305         instance C (x*y) where
 306           op (v :*: w) = ...
 307
 308         instance C 1 where
 309           op Unit      = ...
 310
 311
 312 \begin{code}
 313 getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo]
 314 getGenericInstances class_decls
 315   = mapTc get_generics class_decls              `thenTc` \ gen_inst_infos ->
 316     let
 317         gen_inst_info = concat gen_inst_infos
 318     in
 319     if null gen_inst_info then
 320         returnTc []
 321     else
 322     getDOptsTc                                          `thenTc`  \ dflags ->
 323     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 324                       (vcat (map pprInstInfo gen_inst_info)))
 325                                                         `thenNF_Tc_`
 326     returnTc gen_inst_info
 327
 328 get_generics decl@(ClassDecl {tcdMeths = Nothing})
 329   = returnTc [] -- Imported class decls
 330
 331 get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc})
 332   | null groups
 333   = returnTc [] -- The comon case: no generic default methods
 334
 335   | otherwise   -- A source class decl with generic default methods
 336   = recoverNF_Tc (returnNF_Tc [])                               $
 337     tcAddDeclCtxt decl                                          $
 338     tcLookupClass class_name                                    `thenTc` \ clas ->
 339
 340         -- Make an InstInfo out of each group
 341     mapTc (mkGenericInstance clas loc) groups           `thenTc` \ inst_infos ->
 342
 343         -- Check that there is only one InstInfo for each type constructor
 344         -- The main way this can fail is if you write
 345         --      f {| a+b |} ... = ...
 346         --      f {| x+y |} ... = ...
 347         -- Then at this point we'll have an InstInfo for each
 348     let
 349         tc_inst_infos :: [(TyCon, InstInfo)]
 350         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 351
 352         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 353                               group `lengthExceeds` 1]
 354         get_uniq (tc,_) = getUnique tc
 355     in
 356     mapTc (addErrTc . dupGenericInsts) bad_groups       `thenTc_`
 357
 358         -- Check that there is an InstInfo for each generic type constructor
 359     let
 360         missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
 361     in
 362     checkTc (null missing) (missingGenericInstances missing)    `thenTc_`
 363
 364     returnTc inst_infos
 365
 366   where
 367         -- Group the declarations by type pattern
 368         groups :: [(RenamedHsType, RenamedMonoBinds)]
 369         groups = assocElts (getGenericBinds def_methods)
 370
 371
 372 ---------------------------------
 373 getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
 374   -- Takes a group of method bindings, finds the generic ones, and returns
 375   -- them in finite map indexed by the type parameter in the definition.
 376
 377 getGenericBinds EmptyMonoBinds    = emptyAssoc
 378 getGenericBinds (AndMonoBinds m1 m2)
 379   = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
 380
 381 getGenericBinds (FunMonoBind id infixop matches loc)
 382   = mapAssoc wrap (foldl add emptyAssoc matches)
 383         -- Using foldl not foldr is vital, else
 384         -- we reverse the order of the bindings!
 385   where
 386     add env match = case maybeGenericMatch match of
 387                       Nothing           -> env
 388                       Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
 389
 390     wrap ms = FunMonoBind id infixop ms loc
 391
 392 ---------------------------------
 393 mkGenericInstance :: Class -> SrcLoc
 394                   -> (RenamedHsType, RenamedMonoBinds)
 395                   -> TcM InstInfo
 396
 397 mkGenericInstance clas loc (hs_ty, binds)
 398   -- Make a generic instance declaration
 399   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 400
 401   =     -- Extract the universally quantified type variables
 402     let
 403         sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
 404     in
 405     tcHsTyVars sig_tvs (kcHsSigType hs_ty)      $ \ tyvars ->
 406
 407         -- Type-check the instance type, and check its form
 408     tcHsSigType GenPatCtxt hs_ty                `thenTc` \ inst_ty ->
 409     checkTc (validGenericInstanceType inst_ty)
 410             (badGenericInstanceType binds)      `thenTc_`
 411
 412         -- Make the dictionary function.
 413     newDFunName clas [inst_ty] loc              `thenNF_Tc` \ dfun_name ->
 414     let
 415         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 416         inst_tys   = [inst_ty]
 417         dfun_id    = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
 418     in
 419
 420     returnTc (InstInfo { iDFunId = dfun_id,
 421                          iBinds = binds, iPrags = [] })
 422 \end{code}
 423
 424
 425 %************************************************************************
 426 %*                                                                      *
 427 \subsection{Type-checking instance declarations, pass 2}
 428 %*                                                                      *
 429 %************************************************************************
 430
 431 \begin{code}
 432 tcInstDecls2 :: [InstInfo]
 433              -> NF_TcM (LIE, TcMonoBinds)
 434
 435 tcInstDecls2 inst_decls
 436 --  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 437   = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 438           (map tcInstDecl2 inst_decls)
 439   where
 440     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 441                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 442                       returnNF_Tc (lie1 `plusLIE` lie2,
 443                                    binds1 `AndMonoBinds` binds2)
 444 \end{code}
 445
 446 ======= New documentation starts here (Sept 92)  ==============
 447
 448 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 449 the dictionary function for this instance declaration.  For example
 450 \begin{verbatim}
 451         instance Foo a => Foo [a] where
 452                 op1 x = ...
 453                 op2 y = ...
 454 \end{verbatim}
 455 might generate something like
 456 \begin{verbatim}
 457         dfun.Foo.List dFoo_a = let op1 x = ...
 458                                    op2 y = ...
 459                                in
 460                                    Dict [op1, op2]
 461 \end{verbatim}
 462
 463 HOWEVER, if the instance decl has no context, then it returns a
 464 bigger @HsBinds@ with declarations for each method.  For example
 465 \begin{verbatim}
 466         instance Foo [a] where
 467                 op1 x = ...
 468                 op2 y = ...
 469 \end{verbatim}
 470 might produce
 471 \begin{verbatim}
 472         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 473         const.Foo.op1.List a x = ...
 474         const.Foo.op2.List a y = ...
 475 \end{verbatim}
 476 This group may be mutually recursive, because (for example) there may
 477 be no method supplied for op2 in which case we'll get
 478 \begin{verbatim}
 479         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 480 \end{verbatim}
 481 that is, the default method applied to the dictionary at this type.
 482
 483 What we actually produce in either case is:
 484
 485         AbsBinds [a] [dfun_theta_dicts]
 486                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 487                  { d = (sd1,sd2, ..., op1, op2, ...)
 488                    op1 = ...
 489                    op2 = ...
 490                  }
 491
 492 The "maybe" says that we only ask AbsBinds to make global constant methods
 493 if the dfun_theta is empty.
 494
 495
 496 For an instance declaration, say,
 497
 498         instance (C1 a, C2 b) => C (T a b) where
 499                 ...
 500
 501 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 502 function whose type is
 503
 504         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 505
 506 Notice that we pass it the superclass dictionaries at the instance type; this
 507 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 508 is the @dfun_theta@ below.
 509
 510 First comes the easy case of a non-local instance decl.
 511
 512
 513 \begin{code}
 514 tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
 515 -- tcInstDecl2 is called *only* on InstInfos
 516
 517 tcInstDecl2 (InstInfo { iDFunId = dfun_id,
 518                         iBinds = monobinds, iPrags = uprags })
 519   =      -- Prime error recovery
 520     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))       $
 521     tcAddSrcLoc (getSrcLoc dfun_id)                             $
 522     tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id)))     $
 523
 524         -- Instantiate the instance decl with tc-style type variables
 525     let
 526         (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
 527     in
 528     tcInstSigTyVars InstTv inst_tyvars          `thenNF_Tc` \ inst_tyvars' ->
 529     let
 530         tenv        = mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')
 531         inst_tys'   = map (substTy tenv) inst_tys
 532         dfun_theta' = substTheta tenv dfun_theta
 533         origin      = InstanceDeclOrigin
 534
 535         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 536
 537         dm_ids    = [dm_id | (_, DefMeth dm_id) <- op_items]
 538         sel_names = [idName sel_id | (sel_id, _) <- op_items]
 539
 540         -- Instantiate the super-class context with inst_tys
 541         sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
 542
 543         -- Find any definitions in monobinds that aren't from the class
 544         bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
 545     in
 546          -- Check that all the method bindings come from this class
 547     mapTc (addErrTc . badMethodErr clas) bad_bndrs              `thenNF_Tc_`
 548
 549          -- Create dictionary Ids from the specified instance contexts.
 550     newDicts origin sc_theta'                    `thenNF_Tc` \ sc_dicts ->
 551     newDicts origin dfun_theta'                  `thenNF_Tc` \ dfun_arg_dicts ->
 552     newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
 553
 554     tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
 555         -- The type variable from the dict fun actually scope
 556         -- over the bindings.  They were gotten from
 557         -- the original instance declaration
 558         tcExtendGlobalValEnv dm_ids (
 559                 -- Default-method Ids may be mentioned in synthesised RHSs
 560
 561         mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
 562                                      dfun_theta'
 563                                      monobinds uprags True)
 564                        op_items
 565     ))                  `thenTc` \ (method_binds_s, insts_needed_s, meth_insts) ->
 566
 567         -- Deal with SPECIALISE instance pragmas by making them
 568         -- look like SPECIALISE pragmas for the dfun
 569     let
 570         dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
 571     in
 572     tcExtendGlobalValEnv [dfun_id] (
 573         tcSpecSigs dfun_prags
 574     )                                   `thenTc` \ (prag_binds, prag_lie) ->
 575
 576         -- Check the overloading constraints of the methods and superclasses
 577     let
 578                  -- These insts are in scope; quite a few, eh?
 579         avail_insts = [this_dict] ++
 580                       dfun_arg_dicts ++
 581                       sc_dicts ++
 582                       meth_insts
 583
 584         methods_lie    = plusLIEs insts_needed_s
 585     in
 586
 587         -- Simplify the constraints from methods
 588     tcAddErrCtxt methodCtxt (
 589       tcSimplifyCheck
 590                  (ptext SLIT("instance declaration context"))
 591                  inst_tyvars'
 592                  avail_insts
 593                  methods_lie
 594     )                                            `thenTc` \ (const_lie1, lie_binds1) ->
 595
 596         -- Figure out bindings for the superclass context
 597     tcAddErrCtxt superClassCtxt (
 598       tcSimplifyCheck
 599                  (ptext SLIT("instance declaration context"))
 600                  inst_tyvars'
 601                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 602                                         -- get bound by just selecting from this_dict!!
 603                  (mkLIE sc_dicts)
 604     )                                           `thenTc` \ (const_lie2, lie_binds2) ->
 605
 606     checkSigTyVars inst_tyvars' emptyVarSet     `thenNF_Tc` \ zonked_inst_tyvars ->
 607
 608         -- Create the result bindings
 609     let
 610         local_dfun_id = setIdLocalExported dfun_id
 611                 -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
 612
 613         dict_constr   = classDataCon clas
 614         scs_and_meths = map instToId (sc_dicts ++ meth_insts)
 615         this_dict_id  = instToId this_dict
 616         inlines       | null dfun_arg_dicts = emptyNameSet
 617                       | otherwise           = unitNameSet (idName dfun_id)
 618                 -- Always inline the dfun; this is an experimental decision
 619                 -- because it makes a big performance difference sometimes.
 620                 -- Often it means we can do the method selection, and then
 621                 -- inline the method as well.  Marcin's idea; see comments below.
 622                 --
 623                 -- BUT: don't inline it if it's a constant dictionary;
 624                 -- we'll get all the benefit without inlining, and we get
 625                 -- a **lot** of code duplication if we inline it
 626
 627         dict_rhs
 628           | null scs_and_meths
 629           =     -- Blatant special case for CCallable, CReturnable
 630                 -- If the dictionary is empty then we should never
 631                 -- select anything from it, so we make its RHS just
 632                 -- emit an error message.  This in turn means that we don't
 633                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 634                 -- Hardly beautiful, but only three extra lines.
 635             HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
 636                   (HsLit (HsString msg))
 637
 638           | otherwise   -- The common case
 639           = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
 640                 -- We don't produce a binding for the dict_constr; instead we
 641                 -- rely on the simplifier to unfold this saturated application
 642                 -- We do this rather than generate an HsCon directly, because
 643                 -- it means that the special cases (e.g. dictionary with only one
 644                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 645                 -- than needing to be repeated here.
 646
 647           where
 648             msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 649
 650         dict_bind    = VarMonoBind this_dict_id dict_rhs
 651         method_binds = andMonoBindList method_binds_s
 652
 653         main_bind
 654           = AbsBinds
 655                  zonked_inst_tyvars
 656                  (map instToId dfun_arg_dicts)
 657                  [(inst_tyvars', local_dfun_id, this_dict_id)]
 658                  inlines
 659                  (lie_binds1    `AndMonoBinds`
 660                   lie_binds2    `AndMonoBinds`
 661                   method_binds  `AndMonoBinds`
 662                   dict_bind)
 663     in
 664     returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 665               main_bind `AndMonoBinds` prag_binds)
 666 \end{code}
 667
 668                 ------------------------------
 669                 Inlining dfuns unconditionally
 670                 ------------------------------
 671
 672 The code above unconditionally inlines dict funs.  Here's why.
 673 Consider this program:
 674
 675     test :: Int -> Int -> Bool
 676     test x y = (x,y) == (y,x) || test y x
 677     -- Recursive to avoid making it inline.
 678
 679 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 680 the code we end up with is good:
 681
 682     Test.$wtest =
 683         \r -> case ==# [ww ww1] of wild {
 684                 PrelBase.False -> Test.$wtest ww1 ww;
 685                 PrelBase.True ->
 686                   case ==# [ww1 ww] of wild1 {
 687                     PrelBase.False -> Test.$wtest ww1 ww;
 688                     PrelBase.True -> PrelBase.True [];
 689                   };
 690             };
 691     Test.test = \r [w w1]
 692             case w of w2 {
 693               PrelBase.I# ww ->
 694                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 695             };
 696
 697 If we don't inline the dfun, the code is not nearly as good:
 698
 699     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 700               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 701             };
 702
 703     Test.$wtest =
 704         \r [ww ww1]
 705             let { y = PrelBase.I#! [ww1]; } in
 706             let { x = PrelBase.I#! [ww]; } in
 707             let { sat_slx = PrelTup.(,)! [y x]; } in
 708             let { sat_sly = PrelTup.(,)! [x y];
 709             } in
 710               case == sat_sly sat_slx of wild {
 711                 PrelBase.False -> Test.$wtest ww1 ww;
 712                 PrelBase.True -> PrelBase.True [];
 713               };
 714
 715     Test.test =
 716         \r [w w1]
 717             case w of w2 {
 718               PrelBase.I# ww ->
 719                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 720             };
 721
 722 Why doesn't GHC inline $fEq?  Because it looks big:
 723
 724     PrelTup.zdfEqZ1T{-rcX-}
 725         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 726             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 727             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 728             let {
 729               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 730               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 731             let {
 732               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 733               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 734             let {
 735               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 736               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 737                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 738                              case ds{-rf5-}
 739                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 740                              case ds1{-rf4-}
 741                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 742                              PrelBase.zaza{-r4e-}
 743                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 744                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 745                              }
 746                              } } in
 747             let {
 748               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 749               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 750                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 751                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 752             } in
 753               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 754
 755 and it's not as bad as it seems, because it's further dramatically
 756 simplified: only zeze2 is extracted and its body is simplified.
 757
 758
 759 %************************************************************************
 760 %*                                                                      *
 761 \subsection{Error messages}
 762 %*                                                                      *
 763 %************************************************************************
 764
 765 \begin{code}
 766 tcAddDeclCtxt decl thing_inside
 767   = tcAddSrcLoc (tcdLoc decl)   $
 768     tcAddErrCtxt ctxt   $
 769     thing_inside
 770   where
 771      thing = case decl of
 772                 ClassDecl {}              -> "class"
 773                 TySynonym {}              -> "type synonym"
 774                 TyData {tcdND = NewType}  -> "newtype"
 775                 TyData {tcdND = DataType} -> "data type"
 776
 777      ctxt = hsep [ptext SLIT("In the"), text thing,
 778                   ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 779
 780 instDeclCtxt inst_ty = ptext SLIT("In the instance declaration for") <+> quotes doc
 781                      where
 782                         doc = case inst_ty of
 783                                 HsForAllTy _ _ (HsPredTy pred) -> ppr pred
 784                                 HsPredTy pred                  -> ppr pred
 785                                 other                          -> ppr inst_ty   -- Don't expect this
 786 \end{code}
 787
 788 \begin{code}
 789 badGenericInstanceType binds
 790   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 791           nest 4 (ppr binds)]
 792
 793 missingGenericInstances missing
 794   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 795
 796 dupGenericInsts tc_inst_infos
 797   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 798           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 799           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 800     ]
 801   where
 802     ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
 803
 804 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 805 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 806 \end{code}