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