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