ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn
  12 import TcHsSyn          ( mkHsConApp )
  13 import TcBinds          ( tcSpecSigs )
  14 import TcClassDcl       ( tcMethodBind, mkMethodBind, badMethodErr,
  15                           tcClassDecl2, getGenericInstances )
  16 import TcRnMonad
  17 import TcMType          ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr,
  18                           checkAmbiguity, SourceTyCtxt(..) )
  19 import TcType           ( mkClassPred, tcSplitForAllTys, tyVarsOfType,
  20                           tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
  21                           TyVarDetails(..), tcSplitDFunTy, pprClassPred )
  22 import Inst             ( InstOrigin(..), tcInstClassOp, newDicts, instToId,
  23                           showLIE, tcExtendLocalInstEnv )
  24 import TcDeriv          ( tcDeriving )
  25 import TcEnv            ( tcExtendGlobalValEnv, tcExtendTyVarEnv2,
  26                           InstInfo(..), InstBindings(..),
  27                           newDFunName, tcExtendLocalValEnv
  28                         )
  29 import TcHsType         ( kcHsSigType, tcHsKindedType )
  30 import TcUnify          ( checkSigTyVars )
  31 import TcSimplify       ( tcSimplifyCheck, tcSimplifyTop )
  32 import Subst            ( mkTyVarSubst, substTheta, substTy )
  33 import DataCon          ( classDataCon )
  34 import Class            ( classBigSig )
  35 import Var              ( Id, idName, idType )
  36 import NameSet
  37 import MkId             ( mkDictFunId, rUNTIME_ERROR_ID )
  38 import FunDeps          ( checkInstFDs )
  39 import Name             ( Name, getSrcLoc )
  40 import NameSet          ( unitNameSet, emptyNameSet, nameSetToList )
  41 import UnicodeUtil      ( stringToUtf8 )
  42 import Maybe            ( catMaybes )
  43 import SrcLoc           ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
  44 import ListSetOps       ( minusList )
  45 import Outputable
  46 import Bag
  47 import FastString
  48 \end{code}
  49
  50 Typechecking instance declarations is done in two passes. The first
  51 pass, made by @tcInstDecls1@, collects information to be used in the
  52 second pass.
  53
  54 This pre-processed info includes the as-yet-unprocessed bindings
  55 inside the instance declaration.  These are type-checked in the second
  56 pass, when the class-instance envs and GVE contain all the info from
  57 all the instance and value decls.  Indeed that's the reason we need
  58 two passes over the instance decls.
  59
  60
  61 Here is the overall algorithm.
  62 Assume that we have an instance declaration
  63
  64     instance c => k (t tvs) where b
  65
  66 \begin{enumerate}
  67 \item
  68 $LIE_c$ is the LIE for the context of class $c$
  69 \item
  70 $betas_bar$ is the free variables in the class method type, excluding the
  71    class variable
  72 \item
  73 $LIE_cop$ is the LIE constraining a particular class method
  74 \item
  75 $tau_cop$ is the tau type of a class method
  76 \item
  77 $LIE_i$ is the LIE for the context of instance $i$
  78 \item
  79 $X$ is the instance constructor tycon
  80 \item
  81 $gammas_bar$ is the set of type variables of the instance
  82 \item
  83 $LIE_iop$ is the LIE for a particular class method instance
  84 \item
  85 $tau_iop$ is the tau type for this instance of a class method
  86 \item
  87 $alpha$ is the class variable
  88 \item
  89 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
  90 \item
  91 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
  92 \end{enumerate}
  93
  94 ToDo: Update the list above with names actually in the code.
  95
  96 \begin{enumerate}
  97 \item
  98 First, make the LIEs for the class and instance contexts, which means
  99 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 100 and make LIElistI and LIEI.
 101 \item
 102 Then process each method in turn.
 103 \item
 104 order the instance methods according to the ordering of the class methods
 105 \item
 106 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 107 \item
 108 Create final dictionary function from bindings generated already
 109 \begin{pseudocode}
 110 df = lambda inst_tyvars
 111        lambda LIEI
 112          let Bop1
 113              Bop2
 114              ...
 115              Bopn
 116          and dbinds_super
 117               in <op1,op2,...,opn,sd1,...,sdm>
 118 \end{pseudocode}
 119 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 120 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 121 \end{enumerate}
 122
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection{Extracting instance decls}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 Gather up the instance declarations from their various sources
 131
 132 \begin{code}
 133 tcInstDecls1    -- Deal with both source-code and imported instance decls
 134    :: [LTyClDecl Name]          -- For deriving stuff
 135    -> [LInstDecl Name]          -- Source code instance decls
 136    -> TcM (TcGblEnv,            -- The full inst env
 137            [InstInfo],          -- Source-code instance decls to process;
 138                                 -- contains all dfuns for this module
 139            [HsBindGroup Name])  -- Supporting bindings for derived instances
 140
 141 tcInstDecls1 tycl_decls inst_decls
 142   = checkNoErrs $
 143         -- Stop if addInstInfos etc discovers any errors
 144         -- (they recover, so that we get more than one error each round)
 145
 146         -- (1) Do the ordinary instance declarations
 147     mappM tcLocalInstDecl1 inst_decls    `thenM` \ local_inst_infos ->
 148
 149     let
 150         local_inst_info = catMaybes local_inst_infos
 151         clas_decls      = filter (isClassDecl.unLoc) tycl_decls
 152     in
 153         -- (2) Instances from generic class declarations
 154     getGenericInstances clas_decls              `thenM` \ generic_inst_info ->
 155
 156         -- Next, construct the instance environment so far, consisting of
 157         --      a) local instance decls
 158         --      b) generic instances
 159     addInsts local_inst_info    $
 160     addInsts generic_inst_info  $
 161
 162         -- (3) Compute instances from "deriving" clauses;
 163         -- This stuff computes a context for the derived instance decl, so it
 164         -- needs to know about all the instances possible; hence inst_env4
 165     tcDeriving tycl_decls       `thenM` \ (deriv_inst_info, deriv_binds, keep_alive) ->
 166     addInsts deriv_inst_info    $
 167
 168     getGblEnv                   `thenM` \ gbl_env ->
 169     returnM (gbl_env { tcg_keep = tcg_keep gbl_env `unionNameSets` keep_alive },
 170              generic_inst_info ++ deriv_inst_info ++ local_inst_info,
 171              deriv_binds)
 172
 173 addInsts :: [InstInfo] -> TcM a -> TcM a
 174 addInsts infos thing_inside
 175   = tcExtendLocalInstEnv (map iDFunId infos) thing_inside
 176 \end{code}
 177
 178 \begin{code}
 179 tcLocalInstDecl1 :: LInstDecl Name
 180                  -> TcM (Maybe InstInfo)        -- Nothing if there was an error
 181         -- A source-file instance declaration
 182         -- Type-check all the stuff before the "where"
 183         --
 184         -- We check for respectable instance type, and context
 185         -- but only do this for non-imported instance decls.
 186         -- Imported ones should have been checked already, and may indeed
 187         -- contain something illegal in normal Haskell, notably
 188         --      instance CCallable [Char]
 189 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
 190   =     -- Prime error recovery, set source location
 191     recoverM (returnM Nothing)          $
 192     addSrcSpan loc                      $
 193     addErrCtxt (instDeclCtxt1 poly_ty)  $
 194
 195         -- Typecheck the instance type itself.  We can't use
 196         -- tcHsSigType, because it's not a valid user type.
 197     kcHsSigType poly_ty                 `thenM` \ kinded_ty ->
 198     tcHsKindedType kinded_ty            `thenM` \ poly_ty' ->
 199     let
 200         (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
 201     in
 202     checkValidTheta InstThetaCtxt theta                 `thenM_`
 203     checkAmbiguity tyvars theta (tyVarsOfType tau)      `thenM_`
 204     checkValidInstHead tau                              `thenM` \ (clas,inst_tys) ->
 205     checkTc (checkInstFDs theta clas inst_tys)
 206             (instTypeErr (pprClassPred clas inst_tys) msg)      `thenM_`
 207     newDFunName clas inst_tys (srcSpanStart loc)                `thenM` \ dfun_name ->
 208     returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys,
 209                               iBinds = VanillaInst binds uprags }))
 210   where
 211     msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
 212 \end{code}
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217 \subsection{Type-checking instance declarations, pass 2}
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 \begin{code}
 222 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
 223              -> TcM (TcLclEnv, LHsBinds Id)
 224 -- (a) From each class declaration,
 225 --      generate any default-method bindings
 226 -- (b) From each instance decl
 227 --      generate the dfun binding
 228
 229 tcInstDecls2 tycl_decls inst_decls
 230   = do  {       -- (a) Default methods from class decls
 231           (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
 232                                     filter (isClassDecl.unLoc) tycl_decls
 233         ; tcExtendLocalValEnv (concat dm_ids_s)         $ do
 234
 235                 -- (b) instance declarations
 236         ; inst_binds_s <- mappM tcInstDecl2 inst_decls
 237
 238                 -- Done
 239         ; tcl_env <- getLclEnv
 240         ; returnM (tcl_env, unionManyBags dm_binds_s    `unionBags`
 241                             unionManyBags inst_binds_s) }
 242 \end{code}
 243
 244 ======= New documentation starts here (Sept 92)  ==============
 245
 246 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 247 the dictionary function for this instance declaration.  For example
 248 \begin{verbatim}
 249         instance Foo a => Foo [a] where
 250                 op1 x = ...
 251                 op2 y = ...
 252 \end{verbatim}
 253 might generate something like
 254 \begin{verbatim}
 255         dfun.Foo.List dFoo_a = let op1 x = ...
 256                                    op2 y = ...
 257                                in
 258                                    Dict [op1, op2]
 259 \end{verbatim}
 260
 261 HOWEVER, if the instance decl has no context, then it returns a
 262 bigger @HsBinds@ with declarations for each method.  For example
 263 \begin{verbatim}
 264         instance Foo [a] where
 265                 op1 x = ...
 266                 op2 y = ...
 267 \end{verbatim}
 268 might produce
 269 \begin{verbatim}
 270         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 271         const.Foo.op1.List a x = ...
 272         const.Foo.op2.List a y = ...
 273 \end{verbatim}
 274 This group may be mutually recursive, because (for example) there may
 275 be no method supplied for op2 in which case we'll get
 276 \begin{verbatim}
 277         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 278 \end{verbatim}
 279 that is, the default method applied to the dictionary at this type.
 280
 281 What we actually produce in either case is:
 282
 283         AbsBinds [a] [dfun_theta_dicts]
 284                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 285                  { d = (sd1,sd2, ..., op1, op2, ...)
 286                    op1 = ...
 287                    op2 = ...
 288                  }
 289
 290 The "maybe" says that we only ask AbsBinds to make global constant methods
 291 if the dfun_theta is empty.
 292
 293
 294 For an instance declaration, say,
 295
 296         instance (C1 a, C2 b) => C (T a b) where
 297                 ...
 298
 299 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 300 function whose type is
 301
 302         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 303
 304 Notice that we pass it the superclass dictionaries at the instance type; this
 305 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 306 is the @dfun_theta@ below.
 307
 308 First comes the easy case of a non-local instance decl.
 309
 310
 311 \begin{code}
 312 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 313
 314 tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
 315   =      -- Prime error recovery
 316     recoverM (returnM emptyBag)                 $
 317     addSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
 318     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
 319     let
 320         inst_ty          = idType dfun_id
 321         (inst_tyvars, _) = tcSplitForAllTys inst_ty
 322                 -- The tyvars of the instance decl scope over the 'where' part
 323                 -- Those tyvars are inside the dfun_id's type, which is a bit
 324                 -- bizarre, but OK so long as you realise it!
 325     in
 326
 327         -- Instantiate the instance decl with tc-style type variables
 328     tcInstType InstTv inst_ty           `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
 329     let
 330         Just pred         = tcSplitPredTy_maybe inst_head'
 331         (clas, inst_tys') = getClassPredTys pred
 332         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 333
 334         -- Instantiate the super-class context with inst_tys
 335         sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta
 336         origin    = InstanceDeclOrigin
 337     in
 338          -- Create dictionary Ids from the specified instance contexts.
 339     newDicts origin sc_theta'           `thenM` \ sc_dicts ->
 340     newDicts origin dfun_theta'         `thenM` \ dfun_arg_dicts ->
 341     newDicts origin [pred]              `thenM` \ [this_dict] ->
 342                 -- Default-method Ids may be mentioned in synthesised RHSs,
 343                 -- but they'll already be in the environment.
 344
 345         ------------------
 346         -- Typecheck the methods
 347     let         -- These insts are in scope; quite a few, eh?
 348         avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
 349     in
 350     tcMethods clas inst_tyvars inst_tyvars'
 351               dfun_theta' inst_tys' avail_insts
 352               op_items binds            `thenM` \ (meth_ids, meth_binds) ->
 353
 354         -- Figure out bindings for the superclass context
 355     tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
 356                 `thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
 357
 358         -- Deal with 'SPECIALISE instance' pragmas by making them
 359         -- look like SPECIALISE pragmas for the dfun
 360     let
 361         uprags = case binds of
 362                        VanillaInst _ uprags -> uprags
 363                        other                -> []
 364         spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty)
 365                      | L loc (SpecInstSig ty) <- uprags ]
 366         xtve = inst_tyvars `zip` inst_tyvars'
 367     in
 368     tcExtendGlobalValEnv [dfun_id] (
 369         tcExtendTyVarEnv2 xtve          $
 370         tcSpecSigs spec_prags
 371     )                                   `thenM` \ prag_binds ->
 372
 373         -- Create the result bindings
 374     let
 375         dict_constr   = classDataCon clas
 376         scs_and_meths = map instToId sc_dicts ++ meth_ids
 377         this_dict_id  = instToId this_dict
 378         inlines       | null dfun_arg_dicts = emptyNameSet
 379                       | otherwise           = unitNameSet (idName dfun_id)
 380                 -- Always inline the dfun; this is an experimental decision
 381                 -- because it makes a big performance difference sometimes.
 382                 -- Often it means we can do the method selection, and then
 383                 -- inline the method as well.  Marcin's idea; see comments below.
 384                 --
 385                 -- BUT: don't inline it if it's a constant dictionary;
 386                 -- we'll get all the benefit without inlining, and we get
 387                 -- a **lot** of code duplication if we inline it
 388                 --
 389                 --      See Note [Inline dfuns] below
 390
 391         dict_rhs
 392           | null scs_and_meths
 393           =     -- Blatant special case for CCallable, CReturnable
 394                 -- If the dictionary is empty then we should never
 395                 -- select anything from it, so we make its RHS just
 396                 -- emit an error message.  This in turn means that we don't
 397                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 398                 -- Hardly beautiful, but only three extra lines.
 399             nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID)
 400                                    [idType this_dict_id])
 401                   (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg))))
 402
 403           | otherwise   -- The common case
 404           = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
 405                 -- We don't produce a binding for the dict_constr; instead we
 406                 -- rely on the simplifier to unfold this saturated application
 407                 -- We do this rather than generate an HsCon directly, because
 408                 -- it means that the special cases (e.g. dictionary with only one
 409                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 410                 -- than needing to be repeated here.
 411
 412           where
 413             msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas)
 414
 415         dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
 416         all_binds  = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds)
 417
 418         main_bind = noLoc $ AbsBinds
 419                          zonked_inst_tyvars
 420                          (map instToId dfun_arg_dicts)
 421                          [(inst_tyvars', dfun_id, this_dict_id)]
 422                          inlines all_binds
 423     in
 424     showLIE (text "instance")           `thenM_`
 425     returnM (unitBag main_bind `unionBags`
 426              prag_binds `unionBags`
 427              sc_binds_outer)
 428
 429
 430 tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
 431           avail_insts op_items (VanillaInst monobinds uprags)
 432   =     -- Check that all the method bindings come from this class
 433     let
 434         sel_names = [idName sel_id | (sel_id, _) <- op_items]
 435         bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
 436     in
 437     mappM (addErrTc . badMethodErr clas) bad_bndrs      `thenM_`
 438
 439         -- Make the method bindings
 440     let
 441         mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
 442     in
 443     mapAndUnzipM mk_method_bind op_items        `thenM` \ (meth_insts, meth_infos) ->
 444
 445         -- And type check them
 446         -- It's really worth making meth_insts available to the tcMethodBind
 447         -- Consider     instance Monad (ST s) where
 448         --                {-# INLINE (>>) #-}
 449         --                (>>) = ...(>>=)...
 450         -- If we don't include meth_insts, we end up with bindings like this:
 451         --      rec { dict = MkD then bind ...
 452         --            then = inline_me (... (GHC.Base.>>= dict) ...)
 453         --            bind = ... }
 454         -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
 455         -- and (b) the inline_me prevents us inlining the >>= selector, which
 456         -- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
 457         -- is not inlined across modules. Rather ironic since this does not
 458         -- happen without the INLINE pragma!
 459         --
 460         -- Solution: make meth_insts available, so that 'then' refers directly
 461         --           to the local 'bind' rather than going via the dictionary.
 462         --
 463         -- BUT WATCH OUT!  If the method type mentions the class variable, then
 464         -- this optimisation is not right.  Consider
 465         --      class C a where
 466         --        op :: Eq a => a
 467         --
 468         --      instance C Int where
 469         --        op = op
 470         -- The occurrence of 'op' on the rhs gives rise to a constraint
 471         --      op at Int
 472         -- The trouble is that the 'meth_inst' for op, which is 'available', also
 473         -- looks like 'op at Int'.  But they are not the same.
 474     let
 475         all_insts      = avail_insts ++ catMaybes meth_insts
 476         xtve           = inst_tyvars `zip` inst_tyvars'
 477         tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags
 478     in
 479     mapM tc_method_bind meth_infos              `thenM` \ meth_binds_s ->
 480
 481     returnM ([meth_id | (_,meth_id,_) <- meth_infos],
 482              unionManyBags meth_binds_s)
 483
 484
 485 -- Derived newtype instances
 486 tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
 487           avail_insts op_items (NewTypeDerived rep_tys)
 488   = getInstLoc InstanceDeclOrigin               `thenM` \ inst_loc ->
 489     mapAndUnzip3M (do_one inst_loc) op_items    `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
 490
 491     tcSimplifyCheck
 492          (ptext SLIT("newtype derived instance"))
 493          inst_tyvars' avail_insts rhs_insts     `thenM` \ lie_binds ->
 494
 495         -- I don't think we have to do the checkSigTyVars thing
 496
 497     returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds)
 498
 499   where
 500     do_one inst_loc (sel_id, _)
 501         = -- The binding is like "op @ NewTy = op @ RepTy"
 502                 -- Make the *binder*, like in mkMethodBind
 503           tcInstClassOp inst_loc sel_id inst_tys'       `thenM` \ meth_inst ->
 504
 505                 -- Make the *occurrence on the rhs*
 506           tcInstClassOp inst_loc sel_id rep_tys'        `thenM` \ rhs_inst ->
 507           let
 508              meth_id = instToId meth_inst
 509           in
 510           return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst)
 511
 512         -- Instantiate rep_tys with the relevant type variables
 513     rep_tys' = map (substTy subst) rep_tys
 514     subst    = mkTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')
 515 \end{code}
 516
 517 Note: [Superclass loops]
 518 ~~~~~~~~~~~~~~~~~~~~~~~~~
 519 We have to be very, very careful when generating superclasses, lest we
 520 accidentally build a loop. Here's an example:
 521
 522   class S a
 523
 524   class S a => C a where { opc :: a -> a }
 525   class S b => D b where { opd :: b -> b }
 526
 527   instance C Int where
 528      opc = opd
 529
 530   instance D Int where
 531      opd = opc
 532
 533 From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
 534 Simplifying, we may well get:
 535         $dfCInt = :C ds1 (opd dd)
 536         dd  = $dfDInt
 537         ds1 = $p1 dd
 538 Notice that we spot that we can extract ds1 from dd.
 539
 540 Alas!  Alack! We can do the same for (instance D Int):
 541
 542         $dfDInt = :D ds2 (opc dc)
 543         dc  = $dfCInt
 544         ds2 = $p1 dc
 545
 546 And now we've defined the superclass in terms of itself.
 547
 548
 549 Solution: treat the superclass context separately, and simplify it
 550 all the way down to nothing on its own.  Don't toss any 'free' parts
 551 out to be simplified together with other bits of context.
 552 Hence the tcSimplifyTop below.
 553
 554 At a more basic level, don't include this_dict in the context wrt
 555 which we simplify sc_dicts, else sc_dicts get bound by just selecting
 556 from this_dict!!
 557
 558 \begin{code}
 559 tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
 560   = addErrCtxt superClassCtxt   $
 561     getLIE (tcSimplifyCheck doc inst_tyvars'
 562                             dfun_arg_dicts
 563                             sc_dicts)           `thenM` \ (sc_binds1, sc_lie) ->
 564
 565         -- It's possible that the superclass stuff might have done unification
 566     checkSigTyVars inst_tyvars'         `thenM` \ zonked_inst_tyvars ->
 567
 568         -- We must simplify this all the way down
 569         -- lest we build superclass loops
 570         -- See Note [Superclass loops] above
 571     tcSimplifyTop sc_lie                `thenM` \ sc_binds2 ->
 572
 573     returnM (zonked_inst_tyvars, sc_binds1, sc_binds2)
 574
 575   where
 576     doc = ptext SLIT("instance declaration superclass context")
 577 \end{code}
 578
 579
 580                 ------------------------------
 581         [Inline dfuns] Inlining dfuns unconditionally
 582                 ------------------------------
 583
 584 The code above unconditionally inlines dict funs.  Here's why.
 585 Consider this program:
 586
 587     test :: Int -> Int -> Bool
 588     test x y = (x,y) == (y,x) || test y x
 589     -- Recursive to avoid making it inline.
 590
 591 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 592 the code we end up with is good:
 593
 594     Test.$wtest =
 595         \r -> case ==# [ww ww1] of wild {
 596                 PrelBase.False -> Test.$wtest ww1 ww;
 597                 PrelBase.True ->
 598                   case ==# [ww1 ww] of wild1 {
 599                     PrelBase.False -> Test.$wtest ww1 ww;
 600                     PrelBase.True -> PrelBase.True [];
 601                   };
 602             };
 603     Test.test = \r [w w1]
 604             case w of w2 {
 605               PrelBase.I# ww ->
 606                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 607             };
 608
 609 If we don't inline the dfun, the code is not nearly as good:
 610
 611     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 612               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 613             };
 614
 615     Test.$wtest =
 616         \r [ww ww1]
 617             let { y = PrelBase.I#! [ww1]; } in
 618             let { x = PrelBase.I#! [ww]; } in
 619             let { sat_slx = PrelTup.(,)! [y x]; } in
 620             let { sat_sly = PrelTup.(,)! [x y];
 621             } in
 622               case == sat_sly sat_slx of wild {
 623                 PrelBase.False -> Test.$wtest ww1 ww;
 624                 PrelBase.True -> PrelBase.True [];
 625               };
 626
 627     Test.test =
 628         \r [w w1]
 629             case w of w2 {
 630               PrelBase.I# ww ->
 631                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 632             };
 633
 634 Why doesn't GHC inline $fEq?  Because it looks big:
 635
 636     PrelTup.zdfEqZ1T{-rcX-}
 637         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 638             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 639             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 640             let {
 641               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 642               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 643             let {
 644               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 645               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 646             let {
 647               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 648               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 649                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 650                              case ds{-rf5-}
 651                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 652                              case ds1{-rf4-}
 653                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 654                              PrelBase.zaza{-r4e-}
 655                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 656                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 657                              }
 658                              } } in
 659             let {
 660               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 661               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 662                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 663                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 664             } in
 665               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 666
 667 and it's not as bad as it seems, because it's further dramatically
 668 simplified: only zeze2 is extracted and its body is simplified.
 669
 670
 671 %************************************************************************
 672 %*                                                                      *
 673 \subsection{Error messages}
 674 %*                                                                      *
 675 %************************************************************************
 676
 677 \begin{code}
 678 instDeclCtxt1 hs_inst_ty
 679   = inst_decl_ctxt (case unLoc hs_inst_ty of
 680                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
 681                         HsPredTy pred                    -> ppr pred
 682                         other                            -> ppr hs_inst_ty)     -- Don't expect this
 683 instDeclCtxt2 dfun_ty
 684   = inst_decl_ctxt (ppr (mkClassPred cls tys))
 685   where
 686     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 687
 688 inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
 689
 690 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 691 \end{code}