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