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