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