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 TcBinds          ( mkPragFun, tcPrags, badBootDeclErr )
  13 import TcTyClsDecls     ( tcIdxTyInstDecl )
  14 import TcClassDcl       ( tcMethodBind, mkMethodBind, badMethodErr,
  15                           tcClassDecl2, getGenericInstances )
  16 import TcRnMonad
  17 import TcMType          ( tcSkolSigType, checkValidInstance, checkValidInstHead )
  18 import TcType           ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead,
  19                           SkolemInfo(InstSkol), tcSplitDFunTy, mkFunTy )
  20 import Inst             ( newDictBndr, newDictBndrs, instToId, showLIE,
  21                           getOverlapFlag, tcExtendLocalInstEnv )
  22 import InstEnv          ( mkLocalInstance, instanceDFunId )
  23 import TcDeriv          ( tcDeriving )
  24 import TcEnv            ( InstInfo(..), InstBindings(..),
  25                           newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
  26                         )
  27 import TcHsType         ( kcHsSigType, tcHsKindedType )
  28 import TcUnify          ( checkSigTyVars )
  29 import TcSimplify       ( tcSimplifySuperClasses )
  30 import Type             ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
  31                           splitFunTys, TyThing(ATyCon) )
  32 import Coercion         ( mkSymCoercion )
  33 import TyCon            ( TyCon, tyConName, newTyConCo, tyConTyVars,
  34                           isAssocTyCon, tyConFamInst_maybe )
  35 import DataCon          ( classDataCon, dataConTyCon, dataConInstArgTys )
  36 import Class            ( classBigSig )
  37 import Var              ( TyVar, Id, idName, idType, tyVarKind )
  38 import Id               ( mkSysLocal )
  39 import UniqSupply       ( uniqsFromSupply, splitUniqSupply )
  40 import MkId             ( mkDictFunId )
  41 import Name             ( Name, getSrcLoc )
  42 import Maybe            ( isNothing, fromJust, catMaybes )
  43 import Monad            ( when )
  44 import SrcLoc           ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
  45 import ListSetOps       ( minusList )
  46 import Outputable
  47 import Bag
  48 import BasicTypes       ( Activation( AlwaysActive ), InlineSpec(..) )
  49 import HscTypes         ( implicitTyThings )
  50 import FastString
  51 \end{code}
  52
  53 Typechecking instance declarations is done in two passes. The first
  54 pass, made by @tcInstDecls1@, collects information to be used in the
  55 second pass.
  56
  57 This pre-processed info includes the as-yet-unprocessed bindings
  58 inside the instance declaration.  These are type-checked in the second
  59 pass, when the class-instance envs and GVE contain all the info from
  60 all the instance and value decls.  Indeed that's the reason we need
  61 two passes over the instance decls.
  62
  63 Here is the overall algorithm.
  64 Assume that we have an instance declaration
  65
  66     instance c => k (t tvs) where b
  67
  68 \begin{enumerate}
  69 \item
  70 $LIE_c$ is the LIE for the context of class $c$
  71 \item
  72 $betas_bar$ is the free variables in the class method type, excluding the
  73    class variable
  74 \item
  75 $LIE_cop$ is the LIE constraining a particular class method
  76 \item
  77 $tau_cop$ is the tau type of a class method
  78 \item
  79 $LIE_i$ is the LIE for the context of instance $i$
  80 \item
  81 $X$ is the instance constructor tycon
  82 \item
  83 $gammas_bar$ is the set of type variables of the instance
  84 \item
  85 $LIE_iop$ is the LIE for a particular class method instance
  86 \item
  87 $tau_iop$ is the tau type for this instance of a class method
  88 \item
  89 $alpha$ is the class variable
  90 \item
  91 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
  92 \item
  93 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
  94 \end{enumerate}
  95
  96 ToDo: Update the list above with names actually in the code.
  97
  98 \begin{enumerate}
  99 \item
 100 First, make the LIEs for the class and instance contexts, which means
 101 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 102 and make LIElistI and LIEI.
 103 \item
 104 Then process each method in turn.
 105 \item
 106 order the instance methods according to the ordering of the class methods
 107 \item
 108 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 109 \item
 110 Create final dictionary function from bindings generated already
 111 \begin{pseudocode}
 112 df = lambda inst_tyvars
 113        lambda LIEI
 114          let Bop1
 115              Bop2
 116              ...
 117              Bopn
 118          and dbinds_super
 119               in <op1,op2,...,opn,sd1,...,sdm>
 120 \end{pseudocode}
 121 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 122 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 123 \end{enumerate}
 124
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection{Extracting instance decls}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 Gather up the instance declarations from their various sources
 133
 134 \begin{code}
 135 tcInstDecls1    -- Deal with both source-code and imported instance decls
 136    :: [LTyClDecl Name]          -- For deriving stuff
 137    -> [LInstDecl Name]          -- Source code instance decls
 138    -> TcM (TcGblEnv,            -- The full inst env
 139            [InstInfo],          -- Source-code instance decls to process;
 140                                 -- contains all dfuns for this module
 141            HsValBinds Name)     -- Supporting bindings for derived instances
 142
 143 tcInstDecls1 tycl_decls inst_decls
 144   = checkNoErrs $
 145     do {        -- Stop if addInstInfos etc discovers any errors
 146                 -- (they recover, so that we get more than one error each
 147                 -- round)
 148
 149                 -- (1) Do the ordinary instance declarations and instances of
 150                 --     indexed types
 151        ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
 152        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
 153        ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
 154
 155        ; let { (local_infos,
 156                 local_tycons)    = unzip local_info_tycons
 157              ; (idxty_infos,
 158                 idxty_tycons)    = unzip idxty_info_tycons
 159              ; local_idxty_info  = concat local_infos ++ catMaybes idxty_infos
 160              ; local_idxty_tycon = concat local_tycons ++
 161                                    catMaybes idxty_tycons
 162              ; clas_decls        = filter (isClassDecl.unLoc) tycl_decls
 163              ; implicit_things   = concatMap implicitTyThings local_idxty_tycon
 164              }
 165
 166                 -- (2) Add the tycons of associated types and their implicit
 167                 --     tythings to the global environment
 168        ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do {
 169
 170                 -- (3) Instances from generic class declarations
 171        ; generic_inst_info <- getGenericInstances clas_decls
 172
 173                 -- Next, construct the instance environment so far, consisting
 174                 -- of
 175                 --   a) local instance decls
 176                 --   b) generic instances
 177        ; addInsts local_idxty_info  $ do {
 178        ; addInsts generic_inst_info $ do {
 179
 180                 -- (4) Compute instances from "deriving" clauses;
 181                 -- This stuff computes a context for the derived instance
 182                 -- decl, so it needs to know about all the instances possible
 183        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
 184        ; addInsts deriv_inst_info   $ do {
 185
 186        ; gbl_env <- getGblEnv
 187        ; returnM (gbl_env,
 188                   generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
 189                   deriv_binds)
 190     }}}}}
 191   where
 192     -- Make sure that toplevel type instance are not for associated types.
 193     -- !!!TODO: Need to perform this check for the InstInfo structures of type
 194     --          functions, too.
 195     tcIdxTyInstDeclTL ldecl@(L loc decl) =
 196       do { (info, tything) <- tcIdxTyInstDecl ldecl
 197          ; setSrcSpan loc $
 198              when (isAssocFamily tything) $
 199                addErr $ assocInClassErr (tcdName decl)
 200          ; return (info, tything)
 201          }
 202     isAssocFamily (Just (ATyCon tycon)) =
 203       case tyConFamInst_maybe tycon of
 204         Nothing       -> panic "isAssocFamily: no family?!?"
 205         Just (fam, _) -> isAssocTyCon fam
 206     isAssocFamily (Just _             ) = panic "isAssocFamily: no tycon?!?"
 207     isAssocFamily Nothing               = False
 208
 209 assocInClassErr name =
 210   ptext SLIT("Associated type must be inside class instance") <+>
 211   quotes (ppr name)
 212
 213 addInsts :: [InstInfo] -> TcM a -> TcM a
 214 addInsts infos thing_inside
 215   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 216 \end{code}
 217
 218 \begin{code}
 219 tcLocalInstDecl1 :: LInstDecl Name
 220                  -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
 221         -- A source-file instance declaration
 222         -- Type-check all the stuff before the "where"
 223         --
 224         -- We check for respectable instance type, and context
 225 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
 226   =     -- Prime error recovery, set source location
 227     recoverM (returnM ([], []))         $
 228     setSrcSpan loc                      $
 229     addErrCtxt (instDeclCtxt1 poly_ty)  $
 230
 231     do  { is_boot <- tcIsHsBoot
 232         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
 233                   badBootDeclErr
 234
 235         -- Typecheck the instance type itself.  We can't use
 236         -- tcHsSigType, because it's not a valid user type.
 237         ; kinded_ty <- kcHsSigType poly_ty
 238         ; poly_ty'  <- tcHsKindedType kinded_ty
 239         ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
 240
 241         -- Now, check the validity of the instance.
 242         ; (clas, inst_tys) <- checkValidInstHead tau
 243         ; checkValidInstance tyvars theta clas inst_tys
 244
 245         -- Next, process any associated types.
 246         ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
 247
 248         -- Finally, construct the Core representation of the instance.
 249         -- (This no longer includes the associated types.)
 250         ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
 251         ; overlap_flag <- getOverlapFlag
 252         ; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
 253               ispec          = mkLocalInstance dfun overlap_flag
 254               (idxty_infos,
 255                idxty_tycons) = unzip idxty_info_tycons
 256
 257         ; return ([InstInfo { iSpec  = ispec,
 258                               iBinds = VanillaInst binds uprags }] ++
 259                   catMaybes idxty_infos,
 260                   catMaybes idxty_tycons)
 261         }
 262 \end{code}
 263
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection{Type-checking instance declarations, pass 2}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 \begin{code}
 272 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
 273              -> TcM (LHsBinds Id, TcLclEnv)
 274 -- (a) From each class declaration,
 275 --      generate any default-method bindings
 276 -- (b) From each instance decl
 277 --      generate the dfun binding
 278
 279 tcInstDecls2 tycl_decls inst_decls
 280   = do  {       -- (a) Default methods from class decls
 281           (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
 282                                     filter (isClassDecl.unLoc) tycl_decls
 283         ; tcExtendIdEnv (concat dm_ids_s)       $ do
 284
 285                 -- (b) instance declarations
 286         ; inst_binds_s <- mappM tcInstDecl2 inst_decls
 287
 288                 -- Done
 289         ; let binds = unionManyBags dm_binds_s `unionBags`
 290                       unionManyBags inst_binds_s
 291         ; tcl_env <- getLclEnv          -- Default method Ids in here
 292         ; returnM (binds, tcl_env) }
 293 \end{code}
 294
 295 ======= New documentation starts here (Sept 92)  ==============
 296
 297 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 298 the dictionary function for this instance declaration.  For example
 299 \begin{verbatim}
 300         instance Foo a => Foo [a] where
 301                 op1 x = ...
 302                 op2 y = ...
 303 \end{verbatim}
 304 might generate something like
 305 \begin{verbatim}
 306         dfun.Foo.List dFoo_a = let op1 x = ...
 307                                    op2 y = ...
 308                                in
 309                                    Dict [op1, op2]
 310 \end{verbatim}
 311
 312 HOWEVER, if the instance decl has no context, then it returns a
 313 bigger @HsBinds@ with declarations for each method.  For example
 314 \begin{verbatim}
 315         instance Foo [a] where
 316                 op1 x = ...
 317                 op2 y = ...
 318 \end{verbatim}
 319 might produce
 320 \begin{verbatim}
 321         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 322         const.Foo.op1.List a x = ...
 323         const.Foo.op2.List a y = ...
 324 \end{verbatim}
 325 This group may be mutually recursive, because (for example) there may
 326 be no method supplied for op2 in which case we'll get
 327 \begin{verbatim}
 328         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 329 \end{verbatim}
 330 that is, the default method applied to the dictionary at this type.
 331
 332 What we actually produce in either case is:
 333
 334         AbsBinds [a] [dfun_theta_dicts]
 335                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 336                  { d = (sd1,sd2, ..., op1, op2, ...)
 337                    op1 = ...
 338                    op2 = ...
 339                  }
 340
 341 The "maybe" says that we only ask AbsBinds to make global constant methods
 342 if the dfun_theta is empty.
 343
 344
 345 For an instance declaration, say,
 346
 347         instance (C1 a, C2 b) => C (T a b) where
 348                 ...
 349
 350 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 351 function whose type is
 352
 353         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 354
 355 Notice that we pass it the superclass dictionaries at the instance type; this
 356 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 357 is the @dfun_theta@ below.
 358
 359 First comes the easy case of a non-local instance decl.
 360
 361
 362 \begin{code}
 363 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 364 -- Returns a binding for the dfun
 365
 366 ------------------------
 367 -- Derived newtype instances
 368 --
 369 -- We need to make a copy of the dictionary we are deriving from
 370 -- because we may need to change some of the superclass dictionaries
 371 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
 372 --
 373 -- In the case of a newtype, things are rather easy
 374 --      class Show a => Foo a b where ...
 375 --      newtype T a = MkT (Tree [a]) deriving( Foo Int )
 376 -- The newtype gives an FC axiom looking like
 377 --      axiom CoT a ::  T a :=: Tree [a]
 378 --
 379 -- So all need is to generate a binding looking like
 380 --      dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
 381 --      dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
 382 --                case df `cast` (Foo Int (sym (CoT a))) of
 383 --                   Foo _ op1 .. opn -> Foo ds op1 .. opn
 384
 385 tcInstDecl2 (InstInfo { iSpec = ispec,
 386                         iBinds = NewTypeDerived tycon rep_tys })
 387   = do  { let dfun_id      = instanceDFunId ispec
 388               rigid_info   = InstSkol dfun_id
 389               origin       = SigOrigin rigid_info
 390               inst_ty      = idType dfun_id
 391         ; inst_loc <- getInstLoc origin
 392         ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
 393         ; dicts <- newDictBndrs inst_loc theta
 394         ; uniqs <- newUniqueSupply
 395         ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
 396         ; this_dict <- newDictBndr inst_loc (mkClassPred cls rep_tys)
 397         ; let (rep_dict_id:sc_dict_ids)
 398                  | null dicts = [instToId this_dict]
 399                  | otherwise  = map instToId dicts
 400
 401                 -- (Here, we are relying on the order of dictionary
 402                 -- arguments built by NewTypeDerived in TcDeriv.)
 403
 404               wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids)
 405
 406                 -- we need to find the kind that this class applies to
 407                 -- and drop trailing tvs appropriately
 408               cls_kind = tyVarKind (head (reverse (tyConTyVars cls_tycon)))
 409               the_tvs  = drop_tail (length (fst (splitFunTys cls_kind))) tvs
 410
 411               coerced_rep_dict = mkHsCoerce (co_fn the_tvs cls_tycon cls_inst_tys) (HsVar rep_dict_id)
 412
 413               body | null sc_dict_ids = coerced_rep_dict
 414                    | otherwise = HsCase (noLoc coerced_rep_dict) $
 415                                  MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
 416               in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
 417
 418               the_match = mkSimpleMatch [noLoc the_pat] the_rhs
 419               the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
 420
 421               (uniqs1, uniqs2) = splitUniqSupply uniqs
 422
 423               op_ids = zipWith (mkSysLocal FSLIT("op"))
 424                                       (uniqsFromSupply uniqs1) op_tys
 425
 426               dict_ids = zipWith (mkSysLocal FSLIT("dict"))
 427                           (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
 428
 429               the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
 430                                     pat_dicts = dict_ids,
 431                                     pat_binds = emptyLHsBinds,
 432                                     pat_args = PrefixCon (map nlVarPat op_ids),
 433                                     pat_ty = in_dict_ty}
 434
 435               cls_data_con = classDataCon cls
 436               cls_tycon    = dataConTyCon cls_data_con
 437               cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys
 438
 439               n_dict_args = if length dicts == 0 then 0 else length dicts - 1
 440               op_tys = drop n_dict_args cls_arg_tys
 441
 442               dict    = mkHsCoerce wrap_fn body
 443         ; return (unitBag (noLoc $ VarBind dfun_id (noLoc dict))) }
 444   where
 445         -- For newtype T a = MkT <ty>
 446         -- The returned coercion has kind :: C (T a):=:C <ty>
 447     co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo tycon
 448           = ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++
 449                       [mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))]))
 450           | otherwise
 451           = idCoercion
 452     drop_tail n l = take (length l - n) l
 453
 454 ------------------------
 455 -- Ordinary instances
 456
 457 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
 458   = let
 459         dfun_id    = instanceDFunId ispec
 460         rigid_info = InstSkol dfun_id
 461         inst_ty    = idType dfun_id
 462     in
 463          -- Prime error recovery
 464     recoverM (returnM emptyLHsBinds)            $
 465     setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
 466     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
 467
 468         -- Instantiate the instance decl with skolem constants
 469     tcSkolSigType rigid_info inst_ty    `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
 470                 -- These inst_tyvars' scope over the 'where' part
 471                 -- Those tyvars are inside the dfun_id's type, which is a bit
 472                 -- bizarre, but OK so long as you realise it!
 473     let
 474         (clas, inst_tys') = tcSplitDFunHead inst_head'
 475         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 476
 477         -- Instantiate the super-class context with inst_tys
 478         sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
 479         origin    = SigOrigin rigid_info
 480     in
 481          -- Create dictionary Ids from the specified instance contexts.
 482     getInstLoc InstScOrigin                             `thenM` \ sc_loc ->
 483     newDictBndrs sc_loc sc_theta'                       `thenM` \ sc_dicts ->
 484     getInstLoc origin                                   `thenM` \ inst_loc ->
 485     newDictBndrs inst_loc dfun_theta'                   `thenM` \ dfun_arg_dicts ->
 486     newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
 487                 -- Default-method Ids may be mentioned in synthesised RHSs,
 488                 -- but they'll already be in the environment.
 489
 490         -- Typecheck the methods
 491     let         -- These insts are in scope; quite a few, eh?
 492         avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
 493     in
 494     tcMethods origin clas inst_tyvars'
 495               dfun_theta' inst_tys' avail_insts
 496               op_items monobinds uprags         `thenM` \ (meth_ids, meth_binds) ->
 497
 498         -- Figure out bindings for the superclass context
 499         -- Don't include this_dict in the 'givens', else
 500         -- sc_dicts get bound by just selecting  from this_dict!!
 501     addErrCtxt superClassCtxt
 502         (tcSimplifySuperClasses inst_tyvars'
 503                          dfun_arg_dicts
 504                          sc_dicts)      `thenM` \ sc_binds ->
 505
 506         -- It's possible that the superclass stuff might unified one
 507         -- of the inst_tyavars' with something in the envt
 508     checkSigTyVars inst_tyvars'         `thenM_`
 509
 510         -- Deal with 'SPECIALISE instance' pragmas
 511     tcPrags dfun_id (filter isSpecInstLSig uprags)      `thenM` \ prags ->
 512
 513         -- Create the result bindings
 514     let
 515         dict_constr   = classDataCon clas
 516         scs_and_meths = map instToId sc_dicts ++ meth_ids
 517         this_dict_id  = instToId this_dict
 518         inline_prag | null dfun_arg_dicts = []
 519                     | otherwise = [InlinePrag (Inline AlwaysActive True)]
 520                 -- Always inline the dfun; this is an experimental decision
 521                 -- because it makes a big performance difference sometimes.
 522                 -- Often it means we can do the method selection, and then
 523                 -- inline the method as well.  Marcin's idea; see comments below.
 524                 --
 525                 -- BUT: don't inline it if it's a constant dictionary;
 526                 -- we'll get all the benefit without inlining, and we get
 527                 -- a **lot** of code duplication if we inline it
 528                 --
 529                 --      See Note [Inline dfuns] below
 530
 531         dict_rhs
 532           = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths)
 533                 -- We don't produce a binding for the dict_constr; instead we
 534                 -- rely on the simplifier to unfold this saturated application
 535                 -- We do this rather than generate an HsCon directly, because
 536                 -- it means that the special cases (e.g. dictionary with only one
 537                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 538                 -- than needing to be repeated here.
 539
 540         dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
 541         all_binds  = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
 542
 543         main_bind = noLoc $ AbsBinds
 544                             inst_tyvars'
 545                             (map instToId dfun_arg_dicts)
 546                             [(inst_tyvars', dfun_id, this_dict_id,
 547                                             inline_prag ++ prags)]
 548                             all_binds
 549     in
 550     showLIE (text "instance")           `thenM_`
 551     returnM (unitBag main_bind)
 552
 553
 554 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
 555           avail_insts op_items monobinds uprags
 556   =     -- Check that all the method bindings come from this class
 557     let
 558         sel_names = [idName sel_id | (sel_id, _) <- op_items]
 559         bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
 560     in
 561     mappM (addErrTc . badMethodErr clas) bad_bndrs      `thenM_`
 562
 563         -- Make the method bindings
 564     let
 565         mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
 566     in
 567     mapAndUnzipM mk_method_bind op_items        `thenM` \ (meth_insts, meth_infos) ->
 568
 569         -- And type check them
 570         -- It's really worth making meth_insts available to the tcMethodBind
 571         -- Consider     instance Monad (ST s) where
 572         --                {-# INLINE (>>) #-}
 573         --                (>>) = ...(>>=)...
 574         -- If we don't include meth_insts, we end up with bindings like this:
 575         --      rec { dict = MkD then bind ...
 576         --            then = inline_me (... (GHC.Base.>>= dict) ...)
 577         --            bind = ... }
 578         -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
 579         -- and (b) the inline_me prevents us inlining the >>= selector, which
 580         -- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
 581         -- is not inlined across modules. Rather ironic since this does not
 582         -- happen without the INLINE pragma!
 583         --
 584         -- Solution: make meth_insts available, so that 'then' refers directly
 585         --           to the local 'bind' rather than going via the dictionary.
 586         --
 587         -- BUT WATCH OUT!  If the method type mentions the class variable, then
 588         -- this optimisation is not right.  Consider
 589         --      class C a where
 590         --        op :: Eq a => a
 591         --
 592         --      instance C Int where
 593         --        op = op
 594         -- The occurrence of 'op' on the rhs gives rise to a constraint
 595         --      op at Int
 596         -- The trouble is that the 'meth_inst' for op, which is 'available', also
 597         -- looks like 'op at Int'.  But they are not the same.
 598     let
 599         prag_fn        = mkPragFun uprags
 600         all_insts      = avail_insts ++ catMaybes meth_insts
 601         sig_fn n       = Just []        -- No scoped type variables, but every method has
 602                                         -- a type signature, in effect, so that we check
 603                                         -- the method has the right type
 604         tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
 605         meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
 606     in
 607
 608     mapM tc_method_bind meth_infos              `thenM` \ meth_binds_s ->
 609
 610     returnM (meth_ids, unionManyBags meth_binds_s)
 611 \end{code}
 612
 613
 614                 ------------------------------
 615         [Inline dfuns] Inlining dfuns unconditionally
 616                 ------------------------------
 617
 618 The code above unconditionally inlines dict funs.  Here's why.
 619 Consider this program:
 620
 621     test :: Int -> Int -> Bool
 622     test x y = (x,y) == (y,x) || test y x
 623     -- Recursive to avoid making it inline.
 624
 625 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 626 the code we end up with is good:
 627
 628     Test.$wtest =
 629         \r -> case ==# [ww ww1] of wild {
 630                 PrelBase.False -> Test.$wtest ww1 ww;
 631                 PrelBase.True ->
 632                   case ==# [ww1 ww] of wild1 {
 633                     PrelBase.False -> Test.$wtest ww1 ww;
 634                     PrelBase.True -> PrelBase.True [];
 635                   };
 636             };
 637     Test.test = \r [w w1]
 638             case w of w2 {
 639               PrelBase.I# ww ->
 640                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 641             };
 642
 643 If we don't inline the dfun, the code is not nearly as good:
 644
 645     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 646               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 647             };
 648
 649     Test.$wtest =
 650         \r [ww ww1]
 651             let { y = PrelBase.I#! [ww1]; } in
 652             let { x = PrelBase.I#! [ww]; } in
 653             let { sat_slx = PrelTup.(,)! [y x]; } in
 654             let { sat_sly = PrelTup.(,)! [x y];
 655             } in
 656               case == sat_sly sat_slx of wild {
 657                 PrelBase.False -> Test.$wtest ww1 ww;
 658                 PrelBase.True -> PrelBase.True [];
 659               };
 660
 661     Test.test =
 662         \r [w w1]
 663             case w of w2 {
 664               PrelBase.I# ww ->
 665                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 666             };
 667
 668 Why doesn't GHC inline $fEq?  Because it looks big:
 669
 670     PrelTup.zdfEqZ1T{-rcX-}
 671         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 672             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 673             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 674             let {
 675               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 676               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 677             let {
 678               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 679               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 680             let {
 681               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 682               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 683                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 684                              case ds{-rf5-}
 685                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 686                              case ds1{-rf4-}
 687                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 688                              PrelBase.zaza{-r4e-}
 689                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 690                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 691                              }
 692                              } } in
 693             let {
 694               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 695               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 696                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 697                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 698             } in
 699               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 700
 701 and it's not as bad as it seems, because it's further dramatically
 702 simplified: only zeze2 is extracted and its body is simplified.
 703
 704
 705 %************************************************************************
 706 %*                                                                      *
 707 \subsection{Error messages}
 708 %*                                                                      *
 709 %************************************************************************
 710
 711 \begin{code}
 712 instDeclCtxt1 hs_inst_ty
 713   = inst_decl_ctxt (case unLoc hs_inst_ty of
 714                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
 715                         HsPredTy pred                    -> ppr pred
 716                         other                            -> ppr hs_inst_ty)     -- Don't expect this
 717 instDeclCtxt2 dfun_ty
 718   = inst_decl_ctxt (ppr (mkClassPred cls tys))
 719   where
 720     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 721
 722 inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
 723
 724 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 725 \end{code}