ghc/compiler/typecheck/TcInstDcls.lhs

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