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