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