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, mkMethodBind, badMethodErr )
  27 import TcMonad
  28 import TcMType          ( tcInstType, 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, tcExtendLocalValEnv2,
  38                           tcLookupId, tcLookupClass, tcExtendTyVarEnv2,
  39                           InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
  40                           simpleInstInfoTy, newDFunName
  41                         )
  42 import InstEnv          ( InstEnv, extendInstEnv )
  43 import PprType          ( pprClassPred )
  44 import TcMonoType       ( tcSigPolyId, tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
  45 import TcUnify          ( checkSigTyVars )
  46 import TcSimplify       ( tcSimplifyCheck, tcSimplifyTop )
  47 import HscTypes         ( HomeSymbolTable, DFunId, FixityEnv,
  48                           PersistentCompilerState(..), PersistentRenamerState,
  49                           ModDetails(..)
  50                         )
  51 import Subst            ( mkTyVarSubst, substTheta )
  52 import DataCon          ( classDataCon )
  53 import Class            ( Class, classBigSig )
  54 import Var              ( idName, idType )
  55 import Id               ( setIdLocalExported )
  56 import MkId             ( mkDictFunId, unsafeCoerceId, rUNTIME_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 TysWiredIn       ( genericTyCons )
  64 import SrcLoc           ( SrcLoc )
  65 import Unique           ( Uniquable(..) )
  66 import Util             ( lengthExceeds, isSingleton )
  67 import BasicTypes       ( NewOrData(..) )
  68 import UnicodeUtil      ( stringToUtf8 )
  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 import FastString
  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   = tcInstType 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     let
 539         inst_ty = idType dfun_id
 540         (inst_tyvars, _) = tcSplitForAllTys inst_ty
 541                 -- The tyvars of the instance decl scope over the 'where' part
 542                 -- Those tyvars are inside the dfun_id's type, which is a bit
 543                 -- bizarre, but OK so long as you realise it!
 544     in
 545
 546         -- Instantiate the instance decl with tc-style type variables
 547     tcInstType InstTv inst_ty           `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
 548     let
 549         Just pred         = tcSplitPredTy_maybe inst_head'
 550         (clas, inst_tys') = getClassPredTys pred
 551         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 552
 553         -- Instantiate the super-class context with inst_tys
 554         sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
 555         origin    = InstanceDeclOrigin
 556     in
 557          -- Create dictionary Ids from the specified instance contexts.
 558     newDicts origin sc_theta'           `thenNF_Tc` \ sc_dicts ->
 559     newDicts origin dfun_theta'         `thenNF_Tc` \ dfun_arg_dicts ->
 560     newDicts origin [pred]              `thenNF_Tc` \ [this_dict] ->
 561                 -- Default-method Ids may be mentioned in synthesised RHSs,
 562                 -- but they'll already be in the environment.
 563
 564          -- Check that all the method bindings come from this class
 565     mkMethodBinds clas inst_tys' op_items monobinds `thenTc` \ (meth_insts, meth_infos) ->
 566
 567     let          -- These insts are in scope; quite a few, eh?
 568         avail_insts = [this_dict] ++ dfun_arg_dicts ++
 569                       sc_dicts    ++ meth_insts
 570
 571         xtve    = inst_tyvars `zip` inst_tyvars'
 572         tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts
 573     in
 574     mapAndUnzipTc tc_meth meth_infos            `thenTc` \ (meth_binds_s, meth_lie_s) ->
 575
 576         -- Figure out bindings for the superclass context
 577     tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
 578                 `thenTc` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
 579
 580         -- Deal with SPECIALISE instance pragmas by making them
 581         -- look like SPECIALISE pragmas for the dfun
 582     let
 583         spec_prags = [ SpecSig (idName dfun_id) ty loc
 584                      | SpecInstSig ty loc <- uprags]
 585     in
 586
 587     tcExtendGlobalValEnv [dfun_id] (
 588         tcExtendTyVarEnv2 xtve                                  $
 589         tcExtendLocalValEnv2 [(idName sel_id, tcSigPolyId sig)
 590                              | (sel_id, sig, _) <- meth_infos]  $
 591                 -- Map sel_id to the local method name we are using
 592         tcSpecSigs spec_prags
 593     )                                   `thenTc` \ (prag_binds, prag_lie) ->
 594
 595         -- Create the result bindings
 596     let
 597         local_dfun_id = setIdLocalExported dfun_id
 598                 -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
 599
 600         dict_constr   = classDataCon clas
 601         scs_and_meths = map instToId (sc_dicts ++ meth_insts)
 602         this_dict_id  = instToId this_dict
 603         inlines       | null dfun_arg_dicts = emptyNameSet
 604                       | otherwise           = unitNameSet (idName dfun_id)
 605                 -- Always inline the dfun; this is an experimental decision
 606                 -- because it makes a big performance difference sometimes.
 607                 -- Often it means we can do the method selection, and then
 608                 -- inline the method as well.  Marcin's idea; see comments below.
 609                 --
 610                 -- BUT: don't inline it if it's a constant dictionary;
 611                 -- we'll get all the benefit without inlining, and we get
 612                 -- a **lot** of code duplication if we inline it
 613
 614         dict_rhs
 615           | null scs_and_meths
 616           =     -- Blatant special case for CCallable, CReturnable
 617                 -- If the dictionary is empty then we should never
 618                 -- select anything from it, so we make its RHS just
 619                 -- emit an error message.  This in turn means that we don't
 620                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 621                 -- Hardly beautiful, but only three extra lines.
 622             HsApp (TyApp (HsVar rUNTIME_ERROR_ID) [idType this_dict_id])
 623                   (HsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
 624
 625           | otherwise   -- The common case
 626           = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
 627                 -- We don't produce a binding for the dict_constr; instead we
 628                 -- rely on the simplifier to unfold this saturated application
 629                 -- We do this rather than generate an HsCon directly, because
 630                 -- it means that the special cases (e.g. dictionary with only one
 631                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 632                 -- than needing to be repeated here.
 633
 634           where
 635             msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
 636
 637         dict_bind  = VarMonoBind this_dict_id dict_rhs
 638         meth_binds = andMonoBindList meth_binds_s
 639         all_binds  = sc_binds_inner `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind
 640
 641         main_bind = AbsBinds
 642                          zonked_inst_tyvars
 643                          (map instToId dfun_arg_dicts)
 644                          [(inst_tyvars', local_dfun_id, this_dict_id)]
 645                          inlines all_binds
 646     in
 647     returnTc (plusLIEs meth_lie_s `plusLIE` prag_lie,
 648               main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
 649 \end{code}
 650
 651 We have to be very, very careful when generating superclasses, lest we
 652 accidentally build a loop. Here's an example:
 653
 654   class S a
 655
 656   class S a => C a where { opc :: a -> a }
 657   class S b => D b where { opd :: b -> b }
 658
 659   instance C Int where
 660      opc = opd
 661
 662   instance D Int where
 663      opd = opc
 664
 665 From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
 666 Simplifying, we may well get:
 667         $dfCInt = :C ds1 (opd dd)
 668         dd  = $dfDInt
 669         ds1 = $p1 dd
 670 Notice that we spot that we can extract ds1 from dd.
 671
 672 Alas!  Alack! We can do the same for (instance D Int):
 673
 674         $dfDInt = :D ds2 (opc dc)
 675         dc  = $dfCInt
 676         ds2 = $p1 dc
 677
 678 And now we've defined the superclass in terms of itself.
 679
 680
 681 Solution: treat the superclass context separately, and simplify it
 682 all the way down to nothing on its own.  Don't toss any 'free' parts
 683 out to be simplified together with other bits of context.
 684 Hence the tcSimplifyTop below.
 685
 686 At a more basic level, don't include this_dict in the context wrt
 687 which we simplify sc_dicts, else sc_dicts get bound by just selecting
 688 from this_dict!!
 689
 690 \begin{code}
 691 tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
 692   = tcAddErrCtxt superClassCtxt         $
 693     tcSimplifyCheck doc inst_tyvars'
 694                     dfun_arg_dicts
 695                     (mkLIE sc_dicts)    `thenTc` \ (sc_lie, sc_binds1) ->
 696
 697         -- It's possible that the superclass stuff might have done unification
 698     checkSigTyVars inst_tyvars'         `thenTc` \ zonked_inst_tyvars ->
 699
 700         -- We must simplify this all the way down
 701         -- lest we build superclass loops
 702     tcSimplifyTop sc_lie                `thenTc` \ sc_binds2 ->
 703
 704     returnTc (zonked_inst_tyvars, sc_binds1, sc_binds2)
 705
 706   where
 707     doc = ptext SLIT("instance declaration superclass context")
 708 \end{code}
 709
 710 \begin{code}
 711 mkMethodBinds clas inst_tys' op_items monobinds
 712   =      -- Check that all the method bindings come from this class
 713     mapTc (addErrTc . badMethodErr clas) bad_bndrs      `thenNF_Tc_`
 714
 715         -- Make the method bindings
 716     mapAndUnzipTc mk_method_bind op_items
 717
 718   where
 719     mk_method_bind op_item = mkMethodBind InstanceDeclOrigin clas
 720                                           inst_tys' monobinds op_item
 721
 722         -- Find any definitions in monobinds that aren't from the class
 723     sel_names = [idName sel_id | (sel_id, _) <- op_items]
 724     bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
 725 \end{code}
 726
 727
 728                 ------------------------------
 729                 Inlining dfuns unconditionally
 730                 ------------------------------
 731
 732 The code above unconditionally inlines dict funs.  Here's why.
 733 Consider this program:
 734
 735     test :: Int -> Int -> Bool
 736     test x y = (x,y) == (y,x) || test y x
 737     -- Recursive to avoid making it inline.
 738
 739 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 740 the code we end up with is good:
 741
 742     Test.$wtest =
 743         \r -> case ==# [ww ww1] of wild {
 744                 PrelBase.False -> Test.$wtest ww1 ww;
 745                 PrelBase.True ->
 746                   case ==# [ww1 ww] of wild1 {
 747                     PrelBase.False -> Test.$wtest ww1 ww;
 748                     PrelBase.True -> PrelBase.True [];
 749                   };
 750             };
 751     Test.test = \r [w w1]
 752             case w of w2 {
 753               PrelBase.I# ww ->
 754                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 755             };
 756
 757 If we don't inline the dfun, the code is not nearly as good:
 758
 759     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 760               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 761             };
 762
 763     Test.$wtest =
 764         \r [ww ww1]
 765             let { y = PrelBase.I#! [ww1]; } in
 766             let { x = PrelBase.I#! [ww]; } in
 767             let { sat_slx = PrelTup.(,)! [y x]; } in
 768             let { sat_sly = PrelTup.(,)! [x y];
 769             } in
 770               case == sat_sly sat_slx of wild {
 771                 PrelBase.False -> Test.$wtest ww1 ww;
 772                 PrelBase.True -> PrelBase.True [];
 773               };
 774
 775     Test.test =
 776         \r [w w1]
 777             case w of w2 {
 778               PrelBase.I# ww ->
 779                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 780             };
 781
 782 Why doesn't GHC inline $fEq?  Because it looks big:
 783
 784     PrelTup.zdfEqZ1T{-rcX-}
 785         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 786             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 787             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 788             let {
 789               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 790               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 791             let {
 792               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 793               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 794             let {
 795               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 796               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 797                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 798                              case ds{-rf5-}
 799                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 800                              case ds1{-rf4-}
 801                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 802                              PrelBase.zaza{-r4e-}
 803                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 804                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 805                              }
 806                              } } in
 807             let {
 808               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 809               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 810                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 811                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 812             } in
 813               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 814
 815 and it's not as bad as it seems, because it's further dramatically
 816 simplified: only zeze2 is extracted and its body is simplified.
 817
 818
 819 %************************************************************************
 820 %*                                                                      *
 821 \subsection{Error messages}
 822 %*                                                                      *
 823 %************************************************************************
 824
 825 \begin{code}
 826 tcAddDeclCtxt decl thing_inside
 827   = tcAddSrcLoc (tcdLoc decl)   $
 828     tcAddErrCtxt ctxt   $
 829     thing_inside
 830   where
 831      thing = case decl of
 832                 ClassDecl {}              -> "class"
 833                 TySynonym {}              -> "type synonym"
 834                 TyData {tcdND = NewType}  -> "newtype"
 835                 TyData {tcdND = DataType} -> "data type"
 836
 837      ctxt = hsep [ptext SLIT("In the"), text thing,
 838                   ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 839
 840 instDeclCtxt inst_ty = ptext SLIT("In the instance declaration for") <+> quotes doc
 841                      where
 842                         doc = case inst_ty of
 843                                 HsForAllTy _ _ (HsPredTy pred) -> ppr pred
 844                                 HsPredTy pred                  -> ppr pred
 845                                 other                          -> ppr inst_ty   -- Don't expect this
 846 \end{code}
 847
 848 \begin{code}
 849 badGenericInstanceType binds
 850   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 851           nest 4 (ppr binds)]
 852
 853 missingGenericInstances missing
 854   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 855
 856 dupGenericInsts tc_inst_infos
 857   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 858           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 859           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 860     ]
 861   where
 862     ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
 863
 864 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 865 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 866 \end{code}