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