compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcInstDecls: Typechecking instance declarations
   7
   8 \begin{code}
   9 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
  17
  18 #include "HsVersions.h"
  19
  20 import HsSyn
  21 import TcBinds
  22 import TcTyClsDecls
  23 import TcClassDcl
  24 import TcRnMonad
  25 import TcMType
  26 import TcType
  27 import Inst
  28 import InstEnv
  29 import FamInst
  30 import FamInstEnv
  31 import TcDeriv
  32 import TcEnv
  33 import TcHsType
  34 import TcUnify
  35 import TcSimplify
  36 import Type
  37 import Coercion
  38 import TyCon
  39 import TypeRep
  40 import DataCon
  41 import Class
  42 import Var
  43 import MkId
  44 import Name
  45 import NameSet
  46 import DynFlags
  47 import SrcLoc
  48 import ListSetOps
  49 import Util
  50 import Outputable
  51 import Bag
  52 import BasicTypes
  53 import HscTypes
  54 import FastString
  55
  56 import Data.Maybe
  57 import Control.Monad hiding (zipWithM_, mapAndUnzipM)
  58 import Data.List
  59 \end{code}
  60
  61 Typechecking instance declarations is done in two passes. The first
  62 pass, made by @tcInstDecls1@, collects information to be used in the
  63 second pass.
  64
  65 This pre-processed info includes the as-yet-unprocessed bindings
  66 inside the instance declaration.  These are type-checked in the second
  67 pass, when the class-instance envs and GVE contain all the info from
  68 all the instance and value decls.  Indeed that's the reason we need
  69 two passes over the instance decls.
  70
  71 Here is the overall algorithm.
  72 Assume that we have an instance declaration
  73
  74     instance c => k (t tvs) where b
  75
  76 \begin{enumerate}
  77 \item
  78 $LIE_c$ is the LIE for the context of class $c$
  79 \item
  80 $betas_bar$ is the free variables in the class method type, excluding the
  81    class variable
  82 \item
  83 $LIE_cop$ is the LIE constraining a particular class method
  84 \item
  85 $tau_cop$ is the tau type of a class method
  86 \item
  87 $LIE_i$ is the LIE for the context of instance $i$
  88 \item
  89 $X$ is the instance constructor tycon
  90 \item
  91 $gammas_bar$ is the set of type variables of the instance
  92 \item
  93 $LIE_iop$ is the LIE for a particular class method instance
  94 \item
  95 $tau_iop$ is the tau type for this instance of a class method
  96 \item
  97 $alpha$ is the class variable
  98 \item
  99 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 100 \item
 101 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 102 \end{enumerate}
 103
 104 ToDo: Update the list above with names actually in the code.
 105
 106 \begin{enumerate}
 107 \item
 108 First, make the LIEs for the class and instance contexts, which means
 109 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 110 and make LIElistI and LIEI.
 111 \item
 112 Then process each method in turn.
 113 \item
 114 order the instance methods according to the ordering of the class methods
 115 \item
 116 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 117 \item
 118 Create final dictionary function from bindings generated already
 119 \begin{pseudocode}
 120 df = lambda inst_tyvars
 121        lambda LIEI
 122          let Bop1
 123              Bop2
 124              ...
 125              Bopn
 126          and dbinds_super
 127               in <op1,op2,...,opn,sd1,...,sdm>
 128 \end{pseudocode}
 129 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 130 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 131 \end{enumerate}
 132
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection{Extracting instance decls}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 Gather up the instance declarations from their various sources
 141
 142 \begin{code}
 143 tcInstDecls1    -- Deal with both source-code and imported instance decls
 144    :: [LTyClDecl Name]          -- For deriving stuff
 145    -> [LInstDecl Name]          -- Source code instance decls
 146    -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
 147    -> TcM (TcGblEnv,            -- The full inst env
 148            [InstInfo],          -- Source-code instance decls to process;
 149                                 -- contains all dfuns for this module
 150            HsValBinds Name)     -- Supporting bindings for derived instances
 151
 152 tcInstDecls1 tycl_decls inst_decls deriv_decls
 153   = checkNoErrs $
 154     do {        -- Stop if addInstInfos etc discovers any errors
 155                 -- (they recover, so that we get more than one error each
 156                 -- round)
 157
 158                 -- (1) Do class and family instance declarations
 159        ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
 160        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
 161        ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
 162
 163        ; let { (local_infos,
 164                 at_tycons)     = unzip local_info_tycons
 165              ; local_info      = concat local_infos
 166              ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
 167              ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
 168              ; implicit_things = concatMap implicitTyThings at_idx_tycon
 169              }
 170
 171                 -- (2) Add the tycons of indexed types and their implicit
 172                 --     tythings to the global environment
 173        ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
 174
 175                 -- (3) Instances from generic class declarations
 176        ; generic_inst_info <- getGenericInstances clas_decls
 177
 178                 -- Next, construct the instance environment so far, consisting
 179                 -- of
 180                 --   a) local instance decls
 181                 --   b) generic instances
 182                 --   c) local family instance decls
 183        ; addInsts local_info         $ do {
 184        ; addInsts generic_inst_info  $ do {
 185        ; addFamInsts at_idx_tycon    $ do {
 186
 187                 -- (4) Compute instances from "deriving" clauses;
 188                 -- This stuff computes a context for the derived instance
 189                 -- decl, so it needs to know about all the instances possible
 190                 -- NB: class instance declarations can contain derivings as
 191                 --     part of associated data type declarations
 192        ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
 193                                                       deriv_decls
 194        ; addInsts deriv_inst_info   $ do {
 195
 196        ; gbl_env <- getGblEnv
 197        ; returnM (gbl_env,
 198                   generic_inst_info ++ deriv_inst_info ++ local_info,
 199                   deriv_binds)
 200     }}}}}}
 201   where
 202     -- Make sure that toplevel type instance are not for associated types.
 203     -- !!!TODO: Need to perform this check for the TyThing of type functions,
 204     --          too.
 205     tcIdxTyInstDeclTL ldecl@(L loc decl) =
 206       do { tything <- tcFamInstDecl ldecl
 207          ; setSrcSpan loc $
 208              when (isAssocFamily tything) $
 209                addErr $ assocInClassErr (tcdName decl)
 210          ; return tything
 211          }
 212     isAssocFamily (Just (ATyCon tycon)) =
 213       case tyConFamInst_maybe tycon of
 214         Nothing       -> panic "isAssocFamily: no family?!?"
 215         Just (fam, _) -> isTyConAssoc fam
 216     isAssocFamily (Just _             ) = panic "isAssocFamily: no tycon?!?"
 217     isAssocFamily Nothing               = False
 218
 219 assocInClassErr name =
 220   ptext SLIT("Associated type") <+> quotes (ppr name) <+>
 221   ptext SLIT("must be inside a class instance")
 222
 223 addInsts :: [InstInfo] -> TcM a -> TcM a
 224 addInsts infos thing_inside
 225   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 226
 227 addFamInsts :: [TyThing] -> TcM a -> TcM a
 228 addFamInsts tycons thing_inside
 229   = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
 230   where
 231     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
 232     mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
 233                                                     (ppr tything)
 234 \end{code}
 235
 236 \begin{code}
 237 tcLocalInstDecl1 :: LInstDecl Name
 238                  -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
 239         -- A source-file instance declaration
 240         -- Type-check all the stuff before the "where"
 241         --
 242         -- We check for respectable instance type, and context
 243 tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
 244   =     -- Prime error recovery, set source location
 245     recoverM (returnM ([], []))         $
 246     setSrcSpan loc                      $
 247     addErrCtxt (instDeclCtxt1 poly_ty)  $
 248
 249     do  { is_boot <- tcIsHsBoot
 250         ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
 251                   badBootDeclErr
 252
 253         ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
 254
 255         -- Next, process any associated types.
 256         ; idx_tycons <- mappM tcFamInstDecl ats
 257
 258         -- Now, check the validity of the instance.
 259         ; (clas, inst_tys) <- checkValidInstHead tau
 260         ; checkValidInstance tyvars theta clas inst_tys
 261         ; checkValidAndMissingATs clas (tyvars, inst_tys)
 262                                   (zip ats idx_tycons)
 263
 264         -- Finally, construct the Core representation of the instance.
 265         -- (This no longer includes the associated types.)
 266         ; dfun_name <- newDFunName clas inst_tys loc
 267         ; overlap_flag <- getOverlapFlag
 268         ; let (eq_theta,dict_theta) = partition isEqPred theta
 269               theta'         = eq_theta ++ dict_theta
 270               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
 271               ispec          = mkLocalInstance dfun overlap_flag
 272
 273         ; return ([InstInfo { iSpec  = ispec,
 274                               iBinds = VanillaInst binds uprags }],
 275                   catMaybes idx_tycons)
 276         }
 277   where
 278     -- We pass in the source form and the type checked form of the ATs.  We
 279     -- really need the source form only to be able to produce more informative
 280     -- error messages.
 281     checkValidAndMissingATs :: Class
 282                             -> ([TyVar], [TcType])     -- instance types
 283                             -> [(LTyClDecl Name,       -- source form of AT
 284                                  Maybe TyThing)]       -- Core form of AT
 285                             -> TcM ()
 286     checkValidAndMissingATs clas inst_tys ats
 287       = do { -- Issue a warning for each class AT that is not defined in this
 288              -- instance.
 289            ; let class_ats   = map tyConName (classATs clas)
 290                  defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
 291                  omitted     = filterOut (`elemNameSet` defined_ats) class_ats
 292            ; warn <- doptM Opt_WarnMissingMethods
 293            ; mapM_ (warnTc warn . omittedATWarn) omitted
 294
 295              -- Ensure that all AT indexes that correspond to class parameters
 296              -- coincide with the types in the instance head.  All remaining
 297              -- AT arguments must be variables.  Also raise an error for any
 298              -- type instances that are not associated with this class.
 299            ; mapM_ (checkIndexes clas inst_tys) ats
 300            }
 301
 302     checkIndexes _    _        (hsAT, Nothing)             =
 303       return ()    -- skip, we already had an error here
 304     checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) =
 305 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
 306       checkIndexes' clas inst_tys hsAT
 307                     (tyConTyVars tycon,
 308                      snd . fromJust . tyConFamInst_maybe $ tycon)
 309     checkIndexes _ _ _ = panic "checkIndexes"
 310
 311     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
 312       = let atName = tcdName . unLoc $ hsAT
 313         in
 314         setSrcSpan (getLoc hsAT)       $
 315         addErrCtxt (atInstCtxt atName) $
 316         case find ((atName ==) . tyConName) (classATs clas) of
 317           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
 318           Just atDecl ->
 319             case assocTyConArgPoss_maybe atDecl of
 320               Nothing   -> panic "checkIndexes': AT has no args poss?!?"
 321               Just poss ->
 322
 323                 -- The following is tricky!  We need to deal with three
 324                 -- complications: (1) The AT possibly only uses a subset of
 325                 -- the class parameters as indexes and those it uses may be in
 326                 -- a different order; (2) the AT may have extra arguments,
 327                 -- which must be type variables; and (3) variables in AT and
 328                 -- instance head will be different `Name's even if their
 329                 -- source lexemes are identical.
 330                 --
 331                 -- Re (1), `poss' contains a permutation vector to extract the
 332                 -- class parameters in the right order.
 333                 --
 334                 -- Re (2), we wrap the (permuted) class parameters in a Maybe
 335                 -- type and use Nothing for any extra AT arguments.  (First
 336                 -- equation of `checkIndex' below.)
 337                 --
 338                 -- Re (3), we replace any type variable in the AT parameters
 339                 -- that has the same source lexeme as some variable in the
 340                 -- instance types with the instance type variable sharing its
 341                 -- source lexeme.
 342                 --
 343                 let relevantInstTys = map (instTys !!) poss
 344                     instArgs        = map Just relevantInstTys ++
 345                                       repeat Nothing  -- extra arguments
 346                     renaming        = substSameTyVar atTvs instTvs
 347                 in
 348                 zipWithM_ checkIndex (substTys renaming atTys) instArgs
 349
 350     checkIndex ty Nothing
 351       | isTyVarTy ty         = return ()
 352       | otherwise            = addErrTc $ mustBeVarArgErr ty
 353     checkIndex ty (Just instTy)
 354       | ty `tcEqType` instTy = return ()
 355       | otherwise            = addErrTc $ wrongATArgErr ty instTy
 356
 357     listToNameSet = addListToNameSet emptyNameSet
 358
 359     substSameTyVar []       _            = emptyTvSubst
 360     substSameTyVar (tv:tvs) replacingTvs =
 361       let replacement = case find (tv `sameLexeme`) replacingTvs of
 362                           Nothing  -> mkTyVarTy tv
 363                           Just rtv -> mkTyVarTy rtv
 364           --
 365           tv1 `sameLexeme` tv2 =
 366             nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
 367       in
 368       extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
 369 \end{code}
 370
 371
 372 %************************************************************************
 373 %*                                                                      *
 374 \subsection{Type-checking instance declarations, pass 2}
 375 %*                                                                      *
 376 %************************************************************************
 377
 378 \begin{code}
 379 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
 380              -> TcM (LHsBinds Id, TcLclEnv)
 381 -- (a) From each class declaration,
 382 --      generate any default-method bindings
 383 -- (b) From each instance decl
 384 --      generate the dfun binding
 385
 386 tcInstDecls2 tycl_decls inst_decls
 387   = do  {       -- (a) Default methods from class decls
 388           (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
 389                                     filter (isClassDecl.unLoc) tycl_decls
 390         ; tcExtendIdEnv (concat dm_ids_s)       $ do
 391
 392                 -- (b) instance declarations
 393         ; inst_binds_s <- mappM tcInstDecl2 inst_decls
 394
 395                 -- Done
 396         ; let binds = unionManyBags dm_binds_s `unionBags`
 397                       unionManyBags inst_binds_s
 398         ; tcl_env <- getLclEnv          -- Default method Ids in here
 399         ; returnM (binds, tcl_env) }
 400 \end{code}
 401
 402 ======= New documentation starts here (Sept 92)  ==============
 403
 404 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 405 the dictionary function for this instance declaration.  For example
 406
 407         instance Foo a => Foo [a] where
 408                 op1 x = ...
 409                 op2 y = ...
 410
 411 might generate something like
 412
 413         dfun.Foo.List dFoo_a = let op1 x = ...
 414                                    op2 y = ...
 415                                in
 416                                    Dict [op1, op2]
 417
 418 HOWEVER, if the instance decl has no context, then it returns a
 419 bigger @HsBinds@ with declarations for each method.  For example
 420
 421         instance Foo [a] where
 422                 op1 x = ...
 423                 op2 y = ...
 424
 425 might produce
 426
 427         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 428         const.Foo.op1.List a x = ...
 429         const.Foo.op2.List a y = ...
 430
 431 This group may be mutually recursive, because (for example) there may
 432 be no method supplied for op2 in which case we'll get
 433
 434         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 435
 436 that is, the default method applied to the dictionary at this type.
 437 What we actually produce in either case is:
 438
 439         AbsBinds [a] [dfun_theta_dicts]
 440                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 441                  { d = (sd1,sd2, ..., op1, op2, ...)
 442                    op1 = ...
 443                    op2 = ...
 444                  }
 445
 446 The "maybe" says that we only ask AbsBinds to make global constant methods
 447 if the dfun_theta is empty.
 448
 449 For an instance declaration, say,
 450
 451         instance (C1 a, C2 b) => C (T a b) where
 452                 ...
 453
 454 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 455 function whose type is
 456
 457         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 458
 459 Notice that we pass it the superclass dictionaries at the instance type; this
 460 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 461 is the @dfun_theta@ below.
 462
 463
 464 \begin{code}
 465 tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
 466 -- Returns a binding for the dfun
 467
 468 ------------------------
 469 -- Derived newtype instances; surprisingly tricky!
 470 --
 471 --      class Show a => Foo a b where ...
 472 --      newtype N a = MkN (Tree [a]) deriving( Foo Int )
 473 --
 474 -- The newtype gives an FC axiom looking like
 475 --      axiom CoN a ::  N a :=: Tree [a]
 476 --   (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
 477 --
 478 -- So all need is to generate a binding looking like:
 479 --      dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
 480 --      dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
 481 --                case df `cast` (Foo Int (sym (CoN a))) of
 482 --                   Foo _ op1 .. opn -> Foo ds op1 .. opn
 483 --
 484 -- If there are no superclasses, matters are simpler, because we don't need the case
 485 -- see Note [Newtype deriving superclasses] in TcDeriv.lhs
 486
 487 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
 488   = do  { let dfun_id      = instanceDFunId ispec
 489               rigid_info   = InstSkol
 490               origin       = SigOrigin rigid_info
 491               inst_ty      = idType dfun_id
 492         ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
 493                 -- inst_head_ty is a PredType
 494
 495         ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
 496               (class_tyvars, sc_theta, _, op_items) = classBigSig cls
 497               cls_tycon = classTyCon cls
 498               sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
 499
 500               Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
 501               (nt_tycon, tc_args) = tcSplitTyConApp last_ty     -- Can't fail
 502               rep_ty              = newTyConInstRhs nt_tycon tc_args
 503
 504               rep_pred     = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
 505                                 -- In our example, rep_pred is (Foo Int (Tree [a]))
 506               the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
 507                                 -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)
 508
 509         ; inst_loc   <- getInstLoc origin
 510         ; sc_loc     <- getInstLoc InstScOrigin
 511         ; dfun_dicts <- newDictBndrs inst_loc theta
 512         ; sc_dicts   <- newDictBndrs sc_loc sc_theta'
 513         ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
 514         ; rep_dict   <- newDictBndr inst_loc rep_pred
 515
 516         -- Figure out bindings for the superclass context from dfun_dicts
 517         -- Don't include this_dict in the 'givens', else
 518         -- wanted_sc_insts get bound by just selecting from this_dict!!
 519         ; sc_binds <- addErrCtxt superClassCtxt $
 520                       tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)
 521
 522         ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict))
 523
 524         ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
 525         ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
 526
 527         ; return (unitBag $ noLoc $
 528                   AbsBinds  tvs (map instToId dfun_dicts)
 529                             [(tvs, dfun_id, instToId this_dict, [])]
 530                             (dict_bind `consBag` sc_binds)) }
 531   where
 532       -----------------------
 533       --        make_coercion
 534       -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
 535       -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
 536       --        with kind (C s1 .. sm (T a1 .. ak)  :=:  C s1 .. sm <rep_ty>)
 537       --        where rep_ty is the (eta-reduced) type rep of T
 538       -- So we just replace T with CoT, and insert a 'sym'
 539       -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
 540
 541     make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
 542         | Just co_con <- newTyConCo_maybe nt_tycon
 543         , let co = mkSymCoercion (mkTyConApp co_con tc_args)
 544         = WpCo (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
 545         | otherwise     -- The newtype is transparent; no need for a cast
 546         = idHsWrapper
 547
 548       -----------------------
 549       --     (make_body C tys scs coreced_rep_dict)
 550       --                returns
 551       --     (case coerced_rep_dict of { C _ ops -> C scs ops })
 552       -- But if there are no superclasses, it returns just coerced_rep_dict
 553       -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
 554
 555     make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
 556         | null sc_dicts         -- Case (a)
 557         = return coerced_rep_dict
 558         | otherwise             -- Case (b)
 559         = do { op_ids            <- newSysLocalIds FSLIT("op") op_tys
 560              ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
 561              ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
 562                                          pat_dicts = dummy_sc_dict_ids,
 563                                          pat_binds = emptyLHsBinds,
 564                                          pat_args = PrefixCon (map nlVarPat op_ids),
 565                                          pat_ty = pat_ty}
 566                    the_match = mkSimpleMatch [noLoc the_pat] the_rhs
 567                    the_rhs = mkHsConApp cls_data_con cls_inst_tys $
 568                              map HsVar (sc_dict_ids ++ op_ids)
 569
 570                 -- Warning: this HsCase scrutinises a value with a PredTy, which is
 571                 --          never otherwise seen in Haskell source code. It'd be
 572                 --          nicer to generate Core directly!
 573              ; return (HsCase (noLoc coerced_rep_dict) $
 574                        MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
 575         where
 576           sc_dict_ids  = map instToId sc_dicts
 577           pat_ty       = mkTyConApp cls_tycon cls_inst_tys
 578           cls_data_con = head (tyConDataCons cls_tycon)
 579           cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys
 580           op_tys       = dropList sc_dict_ids cls_arg_tys
 581
 582 ------------------------
 583 -- Ordinary instances
 584
 585 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
 586   = let
 587         dfun_id    = instanceDFunId ispec
 588         rigid_info = InstSkol
 589         inst_ty    = idType dfun_id
 590         loc        = srcLocSpan (getSrcLoc dfun_id)
 591     in
 592          -- Prime error recovery
 593     recoverM (returnM emptyLHsBinds)            $
 594     setSrcSpan loc                              $
 595     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
 596
 597         -- Instantiate the instance decl with skolem constants
 598     tcSkolSigType rigid_info inst_ty    `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
 599                 -- These inst_tyvars' scope over the 'where' part
 600                 -- Those tyvars are inside the dfun_id's type, which is a bit
 601                 -- bizarre, but OK so long as you realise it!
 602     let
 603         (clas, inst_tys') = tcSplitDFunHead inst_head'
 604         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
 605
 606         -- Instantiate the super-class context with inst_tys
 607         sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
 608         (eq_sc_theta',dict_sc_theta')     = partition isEqPred sc_theta'
 609         origin    = SigOrigin rigid_info
 610         (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
 611     in
 612          -- Create dictionary Ids from the specified instance contexts.
 613     getInstLoc InstScOrigin                             `thenM` \ sc_loc ->
 614     newDictBndrs sc_loc dict_sc_theta'                  `thenM` \ sc_dicts ->
 615     getInstLoc origin                                   `thenM` \ inst_loc ->
 616     mkMetaCoVars eq_sc_theta'                           `thenM` \ sc_covars ->
 617     mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)   `thenM` \ wanted_sc_eqs ->
 618     mkCoVars eq_dfun_theta'                             `thenM` \ dfun_covars ->
 619     mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)   `thenM` \ dfun_eqs    ->
 620     newDictBndrs inst_loc dict_dfun_theta'              `thenM` \ dfun_dicts ->
 621     newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
 622                 -- Default-method Ids may be mentioned in synthesised RHSs,
 623                 -- but they'll already be in the environment.
 624
 625         -- Typecheck the methods
 626     let         -- These insts are in scope; quite a few, eh?
 627         dfun_insts      = dfun_eqs ++ dfun_dicts
 628         wanted_sc_insts = wanted_sc_eqs   ++ sc_dicts
 629         given_sc_eqs    = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs
 630         given_sc_insts  = given_sc_eqs   ++ sc_dicts
 631         avail_insts     = [this_dict] ++ dfun_insts ++ given_sc_insts
 632     in
 633     tcMethods origin clas inst_tyvars'
 634               dfun_theta' inst_tys' avail_insts
 635               op_items monobinds uprags         `thenM` \ (meth_ids, meth_binds) ->
 636
 637         -- Figure out bindings for the superclass context
 638         -- Don't include this_dict in the 'givens', else
 639         -- wanted_sc_insts get bound by just selecting  from this_dict!!
 640     addErrCtxt superClassCtxt
 641         (tcSimplifySuperClasses inst_loc
 642                          dfun_insts wanted_sc_insts)    `thenM` \ sc_binds ->
 643
 644         -- It's possible that the superclass stuff might unified one
 645         -- of the inst_tyavars' with something in the envt
 646     checkSigTyVars inst_tyvars'         `thenM_`
 647
 648         -- Deal with 'SPECIALISE instance' pragmas
 649     tcPrags dfun_id (filter isSpecInstLSig uprags)      `thenM` \ prags ->
 650
 651         -- Create the result bindings
 652     let
 653         dict_constr   = classDataCon clas
 654         scs_and_meths = map instToId sc_dicts ++ meth_ids
 655         this_dict_id  = instToId this_dict
 656         inline_prag | null dfun_insts  = []
 657                     | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
 658                 -- Always inline the dfun; this is an experimental decision
 659                 -- because it makes a big performance difference sometimes.
 660                 -- Often it means we can do the method selection, and then
 661                 -- inline the method as well.  Marcin's idea; see comments below.
 662                 --
 663                 -- BUT: don't inline it if it's a constant dictionary;
 664                 -- we'll get all the benefit without inlining, and we get
 665                 -- a **lot** of code duplication if we inline it
 666                 --
 667                 --      See Note [Inline dfuns] below
 668
 669         dict_rhs
 670           = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)  (map HsVar scs_and_meths)
 671                 -- We don't produce a binding for the dict_constr; instead we
 672                 -- rely on the simplifier to unfold this saturated application
 673                 -- We do this rather than generate an HsCon directly, because
 674                 -- it means that the special cases (e.g. dictionary with only one
 675                 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
 676                 -- than needing to be repeated here.
 677
 678         dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
 679         all_binds  = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
 680
 681         main_bind = noLoc $ AbsBinds
 682                             (inst_tyvars' ++ dfun_covars)
 683                             (map instToId dfun_dicts)
 684                             [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
 685                             all_binds
 686     in
 687     showLIE (text "instance")           `thenM_`
 688     returnM (unitBag main_bind)
 689
 690 mkCoVars :: [PredType] -> TcM [TyVar]
 691 mkCoVars = newCoVars . map unEqPred
 692   where
 693     unEqPred (EqPred ty1 ty2) = (ty1, ty2)
 694     unEqPred _                = panic "TcInstDcls.mkCoVars"
 695
 696 mkMetaCoVars :: [PredType] -> TcM [TyVar]
 697 mkMetaCoVars = mappM eqPredToCoVar
 698   where
 699     eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
 700     eqPredToCoVar _                = panic "TcInstDcls.mkMetaCoVars"
 701
 702 tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
 703           avail_insts op_items monobinds uprags
 704   =     -- Check that all the method bindings come from this class
 705     let
 706         sel_names = [idName sel_id | (sel_id, _) <- op_items]
 707         bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
 708     in
 709     mappM (addErrTc . badMethodErr clas) bad_bndrs      `thenM_`
 710
 711         -- Make the method bindings
 712     let
 713         mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
 714     in
 715     mapAndUnzipM mk_method_bind op_items        `thenM` \ (meth_insts, meth_infos) ->
 716
 717         -- And type check them
 718         -- It's really worth making meth_insts available to the tcMethodBind
 719         -- Consider     instance Monad (ST s) where
 720         --                {-# INLINE (>>) #-}
 721         --                (>>) = ...(>>=)...
 722         -- If we don't include meth_insts, we end up with bindings like this:
 723         --      rec { dict = MkD then bind ...
 724         --            then = inline_me (... (GHC.Base.>>= dict) ...)
 725         --            bind = ... }
 726         -- The trouble is that (a) 'then' and 'dict' are mutually recursive,
 727         -- and (b) the inline_me prevents us inlining the >>= selector, which
 728         -- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
 729         -- is not inlined across modules. Rather ironic since this does not
 730         -- happen without the INLINE pragma!
 731         --
 732         -- Solution: make meth_insts available, so that 'then' refers directly
 733         --           to the local 'bind' rather than going via the dictionary.
 734         --
 735         -- BUT WATCH OUT!  If the method type mentions the class variable, then
 736         -- this optimisation is not right.  Consider
 737         --      class C a where
 738         --        op :: Eq a => a
 739         --
 740         --      instance C Int where
 741         --        op = op
 742         -- The occurrence of 'op' on the rhs gives rise to a constraint
 743         --      op at Int
 744         -- The trouble is that the 'meth_inst' for op, which is 'available', also
 745         -- looks like 'op at Int'.  But they are not the same.
 746     let
 747         prag_fn        = mkPragFun uprags
 748         all_insts      = avail_insts ++ catMaybes meth_insts
 749         sig_fn n       = Just []        -- No scoped type variables, but every method has
 750                                         -- a type signature, in effect, so that we check
 751                                         -- the method has the right type
 752         tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
 753         meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
 754     in
 755
 756     mapM tc_method_bind meth_infos              `thenM` \ meth_binds_s ->
 757
 758     returnM (meth_ids, unionManyBags meth_binds_s)
 759 \end{code}
 760
 761
 762                 ------------------------------
 763         [Inline dfuns] Inlining dfuns unconditionally
 764                 ------------------------------
 765
 766 The code above unconditionally inlines dict funs.  Here's why.
 767 Consider this program:
 768
 769     test :: Int -> Int -> Bool
 770     test x y = (x,y) == (y,x) || test y x
 771     -- Recursive to avoid making it inline.
 772
 773 This needs the (Eq (Int,Int)) instance.  If we inline that dfun
 774 the code we end up with is good:
 775
 776     Test.$wtest =
 777         \r -> case ==# [ww ww1] of wild {
 778                 PrelBase.False -> Test.$wtest ww1 ww;
 779                 PrelBase.True ->
 780                   case ==# [ww1 ww] of wild1 {
 781                     PrelBase.False -> Test.$wtest ww1 ww;
 782                     PrelBase.True -> PrelBase.True [];
 783                   };
 784             };
 785     Test.test = \r [w w1]
 786             case w of w2 {
 787               PrelBase.I# ww ->
 788                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 789             };
 790
 791 If we don't inline the dfun, the code is not nearly as good:
 792
 793     (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
 794               PrelBase.:DEq tpl1 tpl2 -> tpl2;
 795             };
 796
 797     Test.$wtest =
 798         \r [ww ww1]
 799             let { y = PrelBase.I#! [ww1]; } in
 800             let { x = PrelBase.I#! [ww]; } in
 801             let { sat_slx = PrelTup.(,)! [y x]; } in
 802             let { sat_sly = PrelTup.(,)! [x y];
 803             } in
 804               case == sat_sly sat_slx of wild {
 805                 PrelBase.False -> Test.$wtest ww1 ww;
 806                 PrelBase.True -> PrelBase.True [];
 807               };
 808
 809     Test.test =
 810         \r [w w1]
 811             case w of w2 {
 812               PrelBase.I# ww ->
 813                   case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
 814             };
 815
 816 Why doesn't GHC inline $fEq?  Because it looks big:
 817
 818     PrelTup.zdfEqZ1T{-rcX-}
 819         = \ @ a{-reT-} :: * @ b{-reS-} :: *
 820             zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
 821             zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
 822             let {
 823               zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
 824               zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
 825             let {
 826               zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
 827               zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
 828             let {
 829               zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 830               zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
 831                                ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
 832                              case ds{-rf5-}
 833                              of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
 834                              case ds1{-rf4-}
 835                              of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
 836                              PrelBase.zaza{-r4e-}
 837                                (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
 838                                (zeze{-rf0-} a2{-reZ-} b2{-reY-})
 839                              }
 840                              } } in
 841             let {
 842               a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
 843               a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
 844                             b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
 845                           PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
 846             } in
 847               PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
 848
 849 and it's not as bad as it seems, because it's further dramatically
 850 simplified: only zeze2 is extracted and its body is simplified.
 851
 852
 853 %************************************************************************
 854 %*                                                                      *
 855 \subsection{Error messages}
 856 %*                                                                      *
 857 %************************************************************************
 858
 859 \begin{code}
 860 instDeclCtxt1 hs_inst_ty
 861   = inst_decl_ctxt (case unLoc hs_inst_ty of
 862                         HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
 863                         HsPredTy pred                    -> ppr pred
 864                         other                            -> ppr hs_inst_ty)     -- Don't expect this
 865 instDeclCtxt2 dfun_ty
 866   = inst_decl_ctxt (ppr (mkClassPred cls tys))
 867   where
 868     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 869
 870 inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
 871
 872 superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
 873
 874 atInstCtxt name = ptext SLIT("In the associated type instance for") <+>
 875                   quotes (ppr name)
 876
 877 mustBeVarArgErr ty =
 878   sep [ ptext SLIT("Arguments that do not correspond to a class parameter") <+>
 879         ptext SLIT("must be variables")
 880       , ptext SLIT("Instead of a variable, found") <+> ppr ty
 881       ]
 882
 883 wrongATArgErr ty instTy =
 884   sep [ ptext SLIT("Type indexes must match class instance head")
 885       , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+>
 886          ppr instTy
 887       ]
 888 \end{code}