TcInstDcls.lhs 41.1 KB
Newer Older
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 13 14
import TcBinds
import TcTyClsDecls
import TcClassDcl
Ian Lynagh's avatar
Ian Lynagh committed
15
import TcRnMonad
16 17 18 19 20 21 22 23
import TcMType
import TcType
import Inst
import InstEnv
import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
24
import RnEnv	( lookupImportedName )
25 26 27 28 29 30
import TcHsType
import TcUnify
import TcSimplify
import Type
import Coercion
import TyCon
31
import TypeRep
32 33 34
import DataCon
import Class
import Var
35
import Id
36 37 38 39 40 41
import MkId
import Name
import NameSet
import DynFlags
import SrcLoc
import Util
42
import Outputable
43
import Maybes
44
import Bag
45 46
import BasicTypes
import HscTypes
47
import FastString
48 49

import Data.Maybe
50
import Control.Monad
51
import Data.List
52 53

#include "HsVersions.h"
54 55 56
\end{code}

Typechecking instance declarations is done in two passes. The first
57 58
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.
59 60 61 62 63 64 65

This pre-processed info includes the as-yet-unprocessed bindings
inside the instance declaration.  These are type-checked in the second
pass, when the class-instance envs and GVE contain all the info from
all the instance and value decls.  Indeed that's the reason we need
two passes over the instance decls.

66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96

Note [How instance declarations are translated]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is how we translation instance declarations into Core

Running example:
	class C a where
	   op1, op2 :: Ix b => a -> b -> b
	   op2 = <dm-rhs>

	instance C a => C [a]
	   {-# INLINE [2] op1 #-}
	   op1 = <rhs>
===>
	-- Method selectors
	op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
	op1 = ...
	op2 = ...

	-- Default methods get the 'self' dictionary as argument
	-- so they can call other methods at the same type
	-- Default methods get the same type as their method selector
	$dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
	$dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
	       -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
	       -- Note [Tricky type variable scoping]

	-- A top-level definition for each instance method
	-- Here op1_i, op2_i are the "instance method Ids"
	{-# INLINE [2] op1_i #-}  -- From the instance decl bindings
	op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
97 98 99 100 101 102 103 104 105 106
	op1_i = /\a. \(d:C a). 
	       let local_op1 :: forall a. (C a, C [a])
	       	   	     => forall b. Ix b => [a] -> b -> b
	             -- Note [Subtle interaction of recursion and overlap]
	           local_op1 = <rhs>
	       	     -- Source code; run the type checker on this
		     -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
		     -- Note [Tricky type variable scoping]

	       in local_op1 a d (df_i a d)
107 108 109 110 111 112

	op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) 

	-- The dictionary function itself
	{-# INLINE df_i #-}	-- Always inline dictionary functions
	df_i :: forall a. C a -> C [a]
113 114 115
	df_i = /\a. \d:C a. letrec d' = MkC (op1_i  a   d)
                                            ($dmop2 [a] d')
	       	    	    in d'
116
		-- But see Note [Default methods in instances]
117
		-- We can't apply the type checker to the default-method call
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141

* The dictionary function itself is inlined as vigorously as we
  possibly can, so that we expose that dictionary constructor to
  selectors as much as poss.  That is why the op_i stuff is in 
  *separate* bindings, so that the df_i binding is small enough
  to inline.  See Note [Inline dfuns unconditionally].

* Note that df_i may be mutually recursive with both op1_i and op2_i.
  It's crucial that df_i is not chosen as the loop breaker, even 
  though op1_i has a (user-specified) INLINE pragma.
  Not even once!  Else op1_i, op2_i may be inlined into df_i.

* Instead the idea is to inline df_i into op1_i, which may then select
  methods from the MkC record, and thereby break the recursion with
  df_i, leaving a *self*-recurisve op1_i.  (If op1_i doesn't call op at
  the same type, it won't mention df_i, so there won't be recursion in
  the first place.)  

* If op1_i is marked INLINE by the user there's a danger that we won't
  inline df_i in it, and that in turn means that (since it'll be a
  loop-breaker because df_i isn't), op1_i will ironically never be 
  inlined.  We need to fix this somehow -- perhaps allowing inlining
  of INLINE funcitons inside other INLINE functions.

142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
  class C a where { op1,op2 :: a -> a }
  instance C a => C [a] where
    op1 x = op2 x ++ op2 x
    op2 x = ...
  intance C [Int] where
    ...

When type-checking the C [a] instance, we need a C [a] dictionary (for
the call of op2).  If we look up in the instance environment, we find
an overlap.  And in *general* the right thing is to complain (see Note
[Overlapping instances] in InstEnv).  But in *this* case it's wrong to
complain, because we just want to delegate to the op2 of this same
instance.  

Why is this justified?  Because we generate a (C [a]) constraint in 
a context in which 'a' cannot be instantiated to anything that matches
other overlapping instances, or else we would not be excecuting this
version of op1 in the first place.

It might even be a bit disguised:

  nullFail :: C [a] => [a] -> [a]
  nullFail x = op2 x ++ op2 x

  instance C a => C [a] where
    op1 x = nullFail x

Precisely this is used in package 'regex-base', module Context.hs.
See the overlapping instances for RegexContext, and the fact that they
call 'nullFail' just like the example above.  The DoCon package also
does the same thing; it shows up in module Fraction.hs

Conclusion: when typechecking the methods in a C [a] instance, we want
to have C [a] available.  That is why we have the strange local let in
the definition of op1_i in the example above.  We can typecheck the
defintion of local_op1, and then supply the "this" argument via an 
explicit call to the dfun (which in turn will be inlined).

183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
Note [Tricky type variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In our example
	class C a where
	   op1, op2 :: Ix b => a -> b -> b
	   op2 = <dm-rhs>

	instance C a => C [a]
	   {-# INLINE [2] op1 #-}
	   op1 = <rhs>

note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
in scope in <rhs>.  In particular, we must make sure that 'b' is in
scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
which brings appropriate tyvars into scope. This happens for both
<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
complained if 'b' is mentioned in <rhs>.

Note [Inline dfuns unconditionally]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The code above unconditionally inlines dict funs.  Here's why.
Consider this program:

    test :: Int -> Int -> Bool
    test x y = (x,y) == (y,x) || test y x
    -- Recursive to avoid making it inline.

This needs the (Eq (Int,Int)) instance.  If we inline that dfun
the code we end up with is good:

    Test.$wtest =
        \r -> case ==# [ww ww1] of wild {
                PrelBase.False -> Test.$wtest ww1 ww;
                PrelBase.True ->
                  case ==# [ww1 ww] of wild1 {
                    PrelBase.False -> Test.$wtest ww1 ww;
                    PrelBase.True -> PrelBase.True [];
                  };
            };
    Test.test = \r [w w1]
            case w of w2 {
              PrelBase.I# ww ->
                  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
            };

If we don't inline the dfun, the code is not nearly as good:

    (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
              PrelBase.:DEq tpl1 tpl2 -> tpl2;
            };

    Test.$wtest =
        \r [ww ww1]
            let { y = PrelBase.I#! [ww1]; } in
            let { x = PrelBase.I#! [ww]; } in
            let { sat_slx = PrelTup.(,)! [y x]; } in
            let { sat_sly = PrelTup.(,)! [x y];
            } in
              case == sat_sly sat_slx of wild {
                PrelBase.False -> Test.$wtest ww1 ww;
                PrelBase.True -> PrelBase.True [];
              };

    Test.test =
        \r [w w1]
            case w of w2 {
              PrelBase.I# ww ->
                  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
            };

Why didn't GHC inline $fEq in those days?  Because it looked big:

    PrelTup.zdfEqZ1T{-rcX-}
        = \ @ a{-reT-} :: * @ b{-reS-} :: *
            zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
            zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
            let {
              zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
              zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
            let {
              zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
              zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
            let {
              zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
              zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
                               ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
                             case ds{-rf5-}
                             of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
                             case ds1{-rf4-}
                             of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
                             PrelBase.zaza{-r4e-}
                               (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
                               (zeze{-rf0-} a2{-reZ-} b2{-reY-})
                             }
                             } } in
            let {
              a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
              a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
                            b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
                          PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
            } in
              PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})

and it's not as bad as it seems, because it's further dramatically
simplified: only zeze2 is extracted and its body is simplified.
288

289 290

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
291
%*                                                                      *
292
\subsection{Extracting instance decls}
Ian Lynagh's avatar
Ian Lynagh committed
293
%*                                                                      *
294 295 296 297
%************************************************************************

Gather up the instance declarations from their various sources

298
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
299 300 301 302 303
tcInstDecls1    -- Deal with both source-code and imported instance decls
   :: [LTyClDecl Name]          -- For deriving stuff
   -> [LInstDecl Name]          -- Source code instance decls
   -> [LDerivDecl Name]         -- Source code stand-alone deriving decls
   -> TcM (TcGblEnv,            -- The full inst env
304
           [InstInfo Name],     -- Source-code instance decls to process;
Ian Lynagh's avatar
Ian Lynagh committed
305 306
                                -- contains all dfuns for this module
           HsValBinds Name)     -- Supporting bindings for derived instances
307

308
tcInstDecls1 tycl_decls inst_decls deriv_decls
309
  = checkNoErrs $
310
    do {        -- Stop if addInstInfos etc discovers any errors
Ian Lynagh's avatar
Ian Lynagh committed
311 312
                -- (they recover, so that we get more than one error each
                -- round)
313

Ian Lynagh's avatar
Ian Lynagh committed
314
                -- (1) Do class and family instance declarations
315
       ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
316 317
       ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
       ; idx_tycons        <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
318

319 320 321
       ; let { (local_info,
                at_tycons_s)   = unzip local_info_tycons
             ; at_idx_tycon    = concat at_tycons_s ++ idx_tycons
Ian Lynagh's avatar
Ian Lynagh committed
322 323 324 325 326 327
             ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
             ; implicit_things = concatMap implicitTyThings at_idx_tycon
             }

                -- (2) Add the tycons of indexed types and their implicit
                --     tythings to the global environment
328
       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
329

Ian Lynagh's avatar
Ian Lynagh committed
330
                -- (3) Instances from generic class declarations
331 332
       ; generic_inst_info <- getGenericInstances clas_decls

Ian Lynagh's avatar
Ian Lynagh committed
333 334 335 336 337
                -- Next, construct the instance environment so far, consisting
                -- of
                --   a) local instance decls
                --   b) generic instances
                --   c) local family instance decls
338 339 340
       ; addInsts local_info         $ do {
       ; addInsts generic_inst_info  $ do {
       ; addFamInsts at_idx_tycon    $ do {
341

Ian Lynagh's avatar
Ian Lynagh committed
342 343 344
                -- (4) Compute instances from "deriving" clauses;
                -- This stuff computes a context for the derived instance
                -- decl, so it needs to know about all the instances possible
345 346
                -- NB: class instance declarations can contain derivings as
                --     part of associated data type declarations
347 348 349
	 failIfErrsM		-- If the addInsts stuff gave any errors, don't
				-- try the deriving stuff, becuase that may give
				-- more errors still
Ian Lynagh's avatar
Ian Lynagh committed
350
       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
351
                                                      deriv_decls
352 353 354
       ; addInsts deriv_inst_info   $ do {

       ; gbl_env <- getGblEnv
355
       ; return (gbl_env,
Ian Lynagh's avatar
Ian Lynagh committed
356 357
                  generic_inst_info ++ deriv_inst_info ++ local_info,
                  deriv_binds)
358
    }}}}}}
359 360
  where
    -- Make sure that toplevel type instance are not for associated types.
361
    -- !!!TODO: Need to perform this check for the TyThing of type functions,
Ian Lynagh's avatar
Ian Lynagh committed
362
    --          too.
363
    tcIdxTyInstDeclTL ldecl@(L loc decl) =
364
      do { tything <- tcFamInstDecl ldecl
Ian Lynagh's avatar
Ian Lynagh committed
365 366 367 368 369
         ; setSrcSpan loc $
             when (isAssocFamily tything) $
               addErr $ assocInClassErr (tcdName decl)
         ; return tything
         }
370
    isAssocFamily (ATyCon tycon) =
371 372
      case tyConFamInst_maybe tycon of
        Nothing       -> panic "isAssocFamily: no family?!?"
Ian Lynagh's avatar
Ian Lynagh committed
373
        Just (fam, _) -> isTyConAssoc fam
374
    isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
375

Ian Lynagh's avatar
Ian Lynagh committed
376
assocInClassErr :: Name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
377 378
assocInClassErr name =
  ptext (sLit "Associated type") <+> quotes (ppr name) <+>
Ian Lynagh's avatar
Ian Lynagh committed
379
  ptext (sLit "must be inside a class instance")
380

381
addInsts :: [InstInfo Name] -> TcM a -> TcM a
382
addInsts infos thing_inside
383
  = tcExtendLocalInstEnv (map iSpec infos) thing_inside
384 385 386

addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
387 388 389
  = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
  where
    mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
Ian Lynagh's avatar
Ian Lynagh committed
390 391
    mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
                                                    (ppr tything)
SamB's avatar
SamB committed
392
\end{code}
393

394
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
395
tcLocalInstDecl1 :: LInstDecl Name
396
                 -> TcM (InstInfo Name, [TyThing])
Ian Lynagh's avatar
Ian Lynagh committed
397 398 399 400
        -- A source-file instance declaration
        -- Type-check all the stuff before the "where"
        --
        -- We check for respectable instance type, and context
Ian Lynagh's avatar
Ian Lynagh committed
401
tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
402
  = setSrcSpan loc		        $
Ian Lynagh's avatar
Ian Lynagh committed
403 404 405 406 407 408 409 410 411 412 413
    addErrCtxt (instDeclCtxt1 poly_ty)  $

    do  { is_boot <- tcIsHsBoot
        ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
                  badBootDeclErr

        ; (tyvars, theta, tau) <- tcHsInstHead poly_ty

        -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau
        ; checkValidInstance tyvars theta clas inst_tys
414 415 416 417 418 419 420

        -- Next, process any associated types.
        ; idx_tycons <- recoverM (return []) $
	  	     do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
		     	; checkValidAndMissingATs clas (tyvars, inst_tys)
                          			  (zip ats idx_tycons)
			; return idx_tycons }
Ian Lynagh's avatar
Ian Lynagh committed
421 422 423

        -- Finally, construct the Core representation of the instance.
        -- (This no longer includes the associated types.)
424 425
        ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
		-- Dfun location is that of instance *header*
Ian Lynagh's avatar
Ian Lynagh committed
426 427
        ; overlap_flag <- getOverlapFlag
        ; let (eq_theta,dict_theta) = partition isEqPred theta
428 429
              theta'         = eq_theta ++ dict_theta
              dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
Ian Lynagh's avatar
Ian Lynagh committed
430
              ispec          = mkLocalInstance dfun overlap_flag
431

432 433 434
        ; return (InstInfo { iSpec  = ispec,
                              iBinds = VanillaInst binds uprags },
                  idx_tycons)
435
        }
436
  where
437 438 439 440
    -- We pass in the source form and the type checked form of the ATs.  We
    -- really need the source form only to be able to produce more informative
    -- error messages.
    checkValidAndMissingATs :: Class
Ian Lynagh's avatar
Ian Lynagh committed
441 442
                            -> ([TyVar], [TcType])     -- instance types
                            -> [(LTyClDecl Name,       -- source form of AT
443
                                 TyThing)]    	       -- Core form of AT
Ian Lynagh's avatar
Ian Lynagh committed
444
                            -> TcM ()
445 446
    checkValidAndMissingATs clas inst_tys ats
      = do { -- Issue a warning for each class AT that is not defined in this
Ian Lynagh's avatar
Ian Lynagh committed
447 448
             -- instance.
           ; let class_ats   = map tyConName (classATs clas)
449
                 defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
Ian Lynagh's avatar
Ian Lynagh committed
450 451 452 453 454 455 456 457 458 459 460
                 omitted     = filterOut (`elemNameSet` defined_ats) class_ats
           ; warn <- doptM Opt_WarnMissingMethods
           ; mapM_ (warnTc warn . omittedATWarn) omitted

             -- Ensure that all AT indexes that correspond to class parameters
             -- coincide with the types in the instance head.  All remaining
             -- AT arguments must be variables.  Also raise an error for any
             -- type instances that are not associated with this class.
           ; mapM_ (checkIndexes clas inst_tys) ats
           }

461
    checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
462
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
Ian Lynagh's avatar
Ian Lynagh committed
463 464 465
      checkIndexes' clas inst_tys hsAT
                    (tyConTyVars tycon,
                     snd . fromJust . tyConFamInst_maybe $ tycon)
466 467 468 469
    checkIndexes _ _ _ = panic "checkIndexes"

    checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
      = let atName = tcdName . unLoc $ hsAT
Ian Lynagh's avatar
Ian Lynagh committed
470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
        in
        setSrcSpan (getLoc hsAT)       $
        addErrCtxt (atInstCtxt atName) $
        case find ((atName ==) . tyConName) (classATs clas) of
          Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
          Just atDecl ->
            case assocTyConArgPoss_maybe atDecl of
              Nothing   -> panic "checkIndexes': AT has no args poss?!?"
              Just poss ->

                -- The following is tricky!  We need to deal with three
                -- complications: (1) The AT possibly only uses a subset of
                -- the class parameters as indexes and those it uses may be in
                -- a different order; (2) the AT may have extra arguments,
                -- which must be type variables; and (3) variables in AT and
                -- instance head will be different `Name's even if their
                -- source lexemes are identical.
                --
                -- Re (1), `poss' contains a permutation vector to extract the
                -- class parameters in the right order.
                --
                -- Re (2), we wrap the (permuted) class parameters in a Maybe
                -- type and use Nothing for any extra AT arguments.  (First
                -- equation of `checkIndex' below.)
                --
                -- Re (3), we replace any type variable in the AT parameters
                -- that has the same source lexeme as some variable in the
                -- instance types with the instance type variable sharing its
                -- source lexeme.
                --
                let relevantInstTys = map (instTys !!) poss
                    instArgs        = map Just relevantInstTys ++
                                      repeat Nothing  -- extra arguments
                    renaming        = substSameTyVar atTvs instTvs
                in
                zipWithM_ checkIndex (substTys renaming atTys) instArgs

    checkIndex ty Nothing
508 509
      | isTyVarTy ty         = return ()
      | otherwise            = addErrTc $ mustBeVarArgErr ty
Ian Lynagh's avatar
Ian Lynagh committed
510
    checkIndex ty (Just instTy)
511 512 513
      | ty `tcEqType` instTy = return ()
      | otherwise            = addErrTc $ wrongATArgErr ty instTy

Ian Lynagh's avatar
Ian Lynagh committed
514
    listToNameSet = addListToNameSet emptyNameSet
515 516

    substSameTyVar []       _            = emptyTvSubst
Ian Lynagh's avatar
Ian Lynagh committed
517
    substSameTyVar (tv:tvs) replacingTvs =
518
      let replacement = case find (tv `sameLexeme`) replacingTvs of
Ian Lynagh's avatar
Ian Lynagh committed
519 520
                        Nothing  -> mkTyVarTy tv
                        Just rtv -> mkTyVarTy rtv
521
          --
Ian Lynagh's avatar
Ian Lynagh committed
522 523
          tv1 `sameLexeme` tv2 =
            nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
524 525
      in
      extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
526 527
\end{code}

528 529

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
530
%*                                                                      *
531
      Type-checking instance declarations, pass 2
Ian Lynagh's avatar
Ian Lynagh committed
532
%*                                                                      *
533 534 535
%************************************************************************

\begin{code}
536
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
Ian Lynagh's avatar
Ian Lynagh committed
537 538 539
             -> TcM (LHsBinds Id, TcLclEnv)
-- (a) From each class declaration,
--      generate any default-method bindings
540
-- (b) From each instance decl
Ian Lynagh's avatar
Ian Lynagh committed
541
--      generate the dfun binding
542 543

tcInstDecls2 tycl_decls inst_decls
Ian Lynagh's avatar
Ian Lynagh committed
544 545 546 547 548 549 550 551 552 553 554 555 556
  = do  { -- (a) Default methods from class decls
          (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
                                    filter (isClassDecl.unLoc) tycl_decls
        ; tcExtendIdEnv (concat dm_ids_s) $ do

          -- (b) instance declarations
        ; inst_binds_s <- mapM tcInstDecl2 inst_decls

          -- Done
        ; let binds = unionManyBags dm_binds_s `unionBags`
                      unionManyBags inst_binds_s
        ; tcl_env <- getLclEnv -- Default method Ids in here
        ; return (binds, tcl_env) }
557 558
\end{code}

559

560
\begin{code}
561
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
562
-- Returns a binding for the dfun
563

564
------------------------
565
-- Derived newtype instances; surprisingly tricky!
566
--
Ian Lynagh's avatar
Ian Lynagh committed
567 568
--      class Show a => Foo a b where ...
--      newtype N a = MkN (Tree [a]) deriving( Foo Int )
569
--
570
-- The newtype gives an FC axiom looking like
Ian Lynagh's avatar
Ian Lynagh committed
571
--      axiom CoN a ::  N a :=: Tree [a]
572
--   (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
573
--
Ian Lynagh's avatar
Ian Lynagh committed
574 575 576 577 578
-- So all need is to generate a binding looking like:
--      dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
--      dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
--                case df `cast` (Foo Int (sym (CoN a))) of
--                   Foo _ op1 .. opn -> Foo ds op1 .. opn
579 580 581
--
-- If there are no superclasses, matters are simpler, because we don't need the case
-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
582

583
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
Ian Lynagh's avatar
Ian Lynagh committed
584 585 586 587 588 589
  = do  { let dfun_id      = instanceDFunId ispec
              rigid_info   = InstSkol
              origin       = SigOrigin rigid_info
              inst_ty      = idType dfun_id
        ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
                -- inst_head_ty is a PredType
590 591

        ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
Ian Lynagh's avatar
Ian Lynagh committed
592
              (class_tyvars, sc_theta, _, _) = classBigSig cls
Ian Lynagh's avatar
Ian Lynagh committed
593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617
              cls_tycon = classTyCon cls
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta

              Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
              (nt_tycon, tc_args) = tcSplitTyConApp last_ty     -- Can't fail
              rep_ty              = newTyConInstRhs nt_tycon tc_args

              rep_pred     = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
                                -- In our example, rep_pred is (Foo Int (Tree [a]))
              the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
                                -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a)

        ; inst_loc   <- getInstLoc origin
        ; sc_loc     <- getInstLoc InstScOrigin
        ; dfun_dicts <- newDictBndrs inst_loc theta
        ; sc_dicts   <- newDictBndrs sc_loc sc_theta'
        ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
        ; rep_dict   <- newDictBndr inst_loc rep_pred

        -- Figure out bindings for the superclass context from dfun_dicts
        -- Don't include this_dict in the 'givens', else
        -- wanted_sc_insts get bound by just selecting from this_dict!!
        ; sc_binds <- addErrCtxt superClassCtxt $
                      tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts)

618
        ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict)
Ian Lynagh's avatar
Ian Lynagh committed
619 620 621 622 623 624 625 626

        ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
        ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)

        ; return (unitBag $ noLoc $
                  AbsBinds  tvs (map instToVar dfun_dicts)
                            [(tvs, dfun_id, instToId this_dict, [])]
                            (dict_bind `consBag` sc_binds)) }
627
  where
628
      -----------------------
Ian Lynagh's avatar
Ian Lynagh committed
629
      --        make_coercion
630 631
      -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
      -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
Ian Lynagh's avatar
Ian Lynagh committed
632 633
      --        with kind (C s1 .. sm (T a1 .. ak)  :=:  C s1 .. sm <rep_ty>)
      --        where rep_ty is the (eta-reduced) type rep of T
634 635 636
      -- So we just replace T with CoT, and insert a 'sym'
      -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced

637
    make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args
Ian Lynagh's avatar
Ian Lynagh committed
638 639
        | Just co_con <- newTyConCo_maybe nt_tycon
        , let co = mkSymCoercion (mkTyConApp co_con tc_args)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
640
        = WpCast (mkTyConApp cls_tycon (initial_cls_inst_tys ++ [co]))
Ian Lynagh's avatar
Ian Lynagh committed
641
        | otherwise     -- The newtype is transparent; no need for a cast
642
        = idHsWrapper
643 644

      -----------------------
645
      --     (make_body C tys scs coreced_rep_dict)
Ian Lynagh's avatar
Ian Lynagh committed
646
      --                returns
647 648 649
      --     (case coerced_rep_dict of { C _ ops -> C scs ops })
      -- But if there are no superclasses, it returns just coerced_rep_dict
      -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
Ian Lynagh's avatar
Ian Lynagh committed
650

651
    make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
Ian Lynagh's avatar
Ian Lynagh committed
652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673
        | null sc_dicts         -- Case (a)
        = return coerced_rep_dict
        | otherwise             -- Case (b)
        = do { op_ids            <- newSysLocalIds (fsLit "op") op_tys
             ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
             ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
                                         pat_dicts = dummy_sc_dict_ids,
                                         pat_binds = emptyLHsBinds,
                                         pat_args = PrefixCon (map nlVarPat op_ids),
                                         pat_ty = pat_ty}
                   the_match = mkSimpleMatch [noLoc the_pat] the_rhs
                   the_rhs = mkHsConApp cls_data_con cls_inst_tys $
                             map HsVar (sc_dict_ids ++ op_ids)

                -- Warning: this HsCase scrutinises a value with a PredTy, which is
                --          never otherwise seen in Haskell source code. It'd be
                --          nicer to generate Core directly!
             ; return (HsCase (noLoc coerced_rep_dict) $
                       MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
        where
          sc_dict_ids  = map instToId sc_dicts
          pat_ty       = mkTyConApp cls_tycon cls_inst_tys
674
          cls_data_con = head (tyConDataCons cls_tycon)
Ian Lynagh's avatar
Ian Lynagh committed
675
          cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys
676
          op_tys       = dropList sc_dict_ids cls_arg_tys
677

678 679 680
------------------------
-- Ordinary instances

681
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
Ian Lynagh's avatar
Ian Lynagh committed
682 683 684 685
  = let
        dfun_id    = instanceDFunId ispec
        rigid_info = InstSkol
        inst_ty    = idType dfun_id
686
        loc        = getSrcSpan dfun_id
687
    in
Ian Lynagh's avatar
Ian Lynagh committed
688 689 690 691
         -- Prime error recovery
    recoverM (return emptyLHsBinds)             $
    setSrcSpan loc                              $
    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do
692

Ian Lynagh's avatar
Ian Lynagh committed
693
        -- Instantiate the instance decl with skolem constants
694
    (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
Ian Lynagh's avatar
Ian Lynagh committed
695 696 697
                -- These inst_tyvars' scope over the 'where' part
                -- Those tyvars are inside the dfun_id's type, which is a bit
                -- bizarre, but OK so long as you realise it!
698
    let
Ian Lynagh's avatar
Ian Lynagh committed
699
        (clas, inst_tys') = tcSplitDFunHead inst_head'
700
        (class_tyvars, sc_theta, _, op_items) = classBigSig clas
701

702
        -- Instantiate the super-class context with inst_tys
Ian Lynagh's avatar
Ian Lynagh committed
703 704 705 706
        sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
        (eq_sc_theta',dict_sc_theta')     = partition isEqPred sc_theta'
        origin    = SigOrigin rigid_info
        (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta'
707

Ian Lynagh's avatar
Ian Lynagh committed
708
         -- Create dictionary Ids from the specified instance contexts.
709 710 711 712 713 714 715 716 717
    sc_loc        <- getInstLoc InstScOrigin
    sc_dicts      <- newDictBndrs sc_loc dict_sc_theta'
    inst_loc      <- getInstLoc origin
    sc_covars     <- mkMetaCoVars eq_sc_theta'
    wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars)
    dfun_covars   <- mkCoVars eq_dfun_theta'
    dfun_eqs      <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars)
    dfun_dicts    <- newDictBndrs inst_loc dict_dfun_theta'
    this_dict     <- newDictBndr inst_loc (mkClassPred clas inst_tys')
Ian Lynagh's avatar
Ian Lynagh committed
718 719
                -- Default-method Ids may be mentioned in synthesised RHSs,
                -- but they'll already be in the environment.
720

Ian Lynagh's avatar
Ian Lynagh committed
721 722
        -- Typecheck the methods
    let -- These insts are in scope; quite a few, eh?
723 724 725 726 727 728 729 730 731
        dfun_insts      = dfun_eqs      ++ dfun_dicts
        wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
        this_dict_id  	= instToId this_dict
        sc_dict_ids   	= map instToId sc_dicts
	dfun_dict_ids 	= map instToId dfun_dicts
	prag_fn		= mkPragFun uprags 
	tc_meth 	= tcInstanceMethod loc clas inst_tyvars'
			  		   (dfun_covars ++ dfun_dict_ids)
                   	  	           dfun_theta' inst_tys'
732 733
					   this_dict_id dfun_id
                        	           prag_fn monobinds
734
    (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items 
735

Ian Lynagh's avatar
Ian Lynagh committed
736 737 738
    -- Figure out bindings for the superclass context
    -- Don't include this_dict in the 'givens', else
    -- wanted_sc_insts get bound by just selecting  from this_dict!!
739 740 741 742
    sc_binds <- addErrCtxt superClassCtxt $
                tcSimplifySuperClasses inst_loc dfun_insts 
		   			   	wanted_sc_insts
		-- Note [Recursive superclasses]
743

Ian Lynagh's avatar
Ian Lynagh committed
744 745
    -- It's possible that the superclass stuff might unified one
    -- of the inst_tyavars' with something in the envt
746
    checkSigTyVars inst_tyvars'
747

Ian Lynagh's avatar
Ian Lynagh committed
748
    -- Deal with 'SPECIALISE instance' pragmas
749
    prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
Ian Lynagh's avatar
Ian Lynagh committed
750 751

    -- Create the result bindings
752
    let
sof's avatar
sof committed
753
        dict_constr   = classDataCon clas
Ian Lynagh's avatar
Ian Lynagh committed
754 755 756 757 758 759 760 761 762 763 764 765 766 767
        inline_prag | null dfun_insts  = []
                    | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
                -- Always inline the dfun; this is an experimental decision
                -- because it makes a big performance difference sometimes.
                -- Often it means we can do the method selection, and then
                -- inline the method as well.  Marcin's idea; see comments below.
                --
                -- BUT: don't inline it if it's a constant dictionary;
                -- we'll get all the benefit without inlining, and we get
                -- a **lot** of code duplication if we inline it
                --
                --      See Note [Inline dfuns] below

        dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
768
                                          (map HsVar sc_dict_ids ++ meth_exprs)
Ian Lynagh's avatar
Ian Lynagh committed
769 770 771 772 773 774 775 776 777 778 779
                -- We don't produce a binding for the dict_constr; instead we
                -- rely on the simplifier to unfold this saturated application
                -- We do this rather than generate an HsCon directly, because
                -- it means that the special cases (e.g. dictionary with only one
                -- member) are dealt with by the common MkId.mkDataConWrapId code rather
                -- than needing to be repeated here.

        dict_bind  = noLoc (VarBind this_dict_id dict_rhs)

        main_bind = noLoc $ AbsBinds
                            (inst_tyvars' ++ dfun_covars)
780
                            dfun_dict_ids
Ian Lynagh's avatar
Ian Lynagh committed
781
                            [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
782
                            (dict_bind `consBag` sc_binds)
783 784

    showLIE (text "instance")
785
    return (main_bind `consBag` unionManyBags meth_binds)
786

787
mkCoVars :: [PredType] -> TcM [TyVar]
788 789 790 791
mkCoVars = newCoVars . map unEqPred
  where
    unEqPred (EqPred ty1 ty2) = (ty1, ty2)
    unEqPred _                = panic "TcInstDcls.mkCoVars"
792 793

mkMetaCoVars :: [PredType] -> TcM [TyVar]
794
mkMetaCoVars = mapM eqPredToCoVar
795 796 797
  where
    eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
    eqPredToCoVar _                = panic "TcInstDcls.mkMetaCoVars"
798
\end{code}
799

800 801 802 803 804 805 806 807
Note [Recursive superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #1470 for why we would *like* to add "this_dict" to the 
available instances here.  But we can't do so because then the superclases
get satisfied by selection from this_dict, and that leads to an immediate
loop.  What we need is to add this_dict to Avails without adding its 
superclasses, and we currently have no way to do that.

808

809 810 811 812 813
%************************************************************************
%*                                                                      *
      Type-checking an instance method
%*                                                                      *
%************************************************************************
814

815 816 817 818 819 820 821
tcInstanceMethod
- Make the method bindings, as a [(NonRec, HsBinds)], one per method
- Remembering to use fresh Name (the instance method Name) as the binder
- Bring the instance method Ids into scope, for the benefit of tcInstSig
- Use sig_fn mapping instance method Name -> instance tyvars
- Ditto prag_fn
- Use tcValBinds to do the checking
Ian Lynagh's avatar
Ian Lynagh committed
822

823 824
\begin{code}
tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
825 826 827
	 	 -> TcThetaType -> [TcType]
		 -> Id -> Id 
          	 -> TcPragFun -> LHsBinds Name 
828 829 830 831 832
	  	 -> (Id, DefMeth)
          	 -> TcM (HsExpr Id, LHsBinds Id)
	-- The returned inst_meth_ids all have types starting
	--	forall tvs. theta => ...

833 834 835
tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys 
		 this_dict_id dfun_id
	         prag_fn binds_in (sel_id, dm_info)
836
  = do	{ uniq <- newUnique
837 838 839 840
	; let local_meth_name = mkInternalName uniq sel_occ loc	-- Same OccName
	      tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
					     this_dict_id dfun_id sel_id 
					     prags local_meth_name
841

842
	; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
843
		-- There is a user-supplied method binding, so use it
844
	    (Just user_bind, _) -> tc_body user_bind
845 846 847 848 849

		-- The user didn't supply a method binding, so we have to make 
		-- up a default binding, in a way depending on the default-method info

	    (Nothing, GenDefMeth) -> do		-- Derivable type classes stuff
850 851
			{ meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
			; tc_body meth_bind }
852 853 854 855 856 857

	    (Nothing, NoDefMeth) -> do		-- No default method in the class
			{ warn <- doptM Opt_WarnMissingMethods		
                        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
				  && reportIfUnused (getOccName sel_id))
					-- Don't warn about _foo methods
858 859
			         omitted_meth_warn
			; return (error_rhs, emptyBag) }
860 861 862 863 864 865 866 867

	    (Nothing, DefMeth) -> do	-- An polymorphic default method
			{   -- Build the typechecked version directly, 
			    -- without calling typecheck_method; 
			    -- see Note [Default methods in instances]
			  dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
					-- Might not be imported, but will be an OrigName
			; dm_id   <- tcLookupId dm_name
868
			; return (wrapId dm_wrapper dm_id, emptyBag) } }
869 870 871 872 873
  where
    sel_name = idName sel_id
    sel_occ  = nameOccName sel_name
    prags    = prag_fn sel_name

874 875
    error_rhs    = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg
    meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
876 877 878 879
    error_id     = L loc (HsVar nO_METHOD_BINDING_ERROR_ID) 
    error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
    error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])

880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931
    dm_wrapper   = WpApp this_dict_id <.> mkWpTyApps inst_tys 

    omitted_meth_warn :: SDoc
    omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
                        <+> quotes (ppr sel_id)

---------------
tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var]
	 	     -> TcThetaType -> [TcType]
		     -> Id -> Id -> Id
          	     -> [LSig Name] -> Name -> LHsBind Name 
          	     -> TcM (HsExpr Id, LHsBinds Id)
tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys
		     this_dict_id dfun_id sel_id 
		     prags local_meth_name bind@(L loc _)
  = do	{ uniq <- newUnique
	; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
	      rho_ty = ASSERT( length sel_tyvars == length inst_tys )
		       substTyWith sel_tyvars inst_tys sel_rho

	      (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
			`orElse` pprPanic "tcInstanceMethod" (ppr sel_id)

	      meth_name = mkInternalName uniq (getOccName local_meth_name) loc
	      meth_ty = mkSigmaTy tyvars theta meth_tau
	      meth_id = mkLocalId meth_name meth_ty
	      
	      local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau
	      local_meth_id = mkLocalId local_meth_name local_meth_ty

	      tv_names = map tyVarName tyvars
    	
		      -- The first predicate should be of form (C a b)
		      -- where C is the class in question
	; MASSERT( case getClassPredTys_maybe first_pred of
			{ Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )

	; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind

	; let full_bind = unitBag $ L loc $
	      		  VarBind meth_id $ L loc $
	      		  mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $
			  HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $ 
			  mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $
			  wrapId meth_wrapper local_meth_id
	      this_dict_bind = unitBag $ L loc $
	      		       VarBind this_dict_id $ L loc $
	      		       wrapId meth_wrapper dfun_id

        ; return (wrapId meth_wrapper meth_id, full_bind) } 
  where
    meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
932

933 934
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
935 936
\end{code}

937 938 939
Note [Default methods in instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
940

941 942 943
   class Baz v x where
      foo :: x -> x
      foo y = y
944

945
   instance Baz Int Int
946

947
From the class decl we get
948

949
   $dmfoo :: forall v x. Baz v x => x -> x
950

951
Notice that the type is ambiguous.  That's fine, though. The instance decl generates
952

953
   $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
Ian Lynagh's avatar
Ian Lynagh committed
954

955 956 957
BUT this does mean we must generate the dictionary translation directly, rather
than generating source-code and type-checking it.  That was the bug ing
Trac #1061. In any case it's less work to generate the translated version!
958

959

960
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
961
%*                                                                      *
962
\subsection{Error messages}
Ian Lynagh's avatar
Ian Lynagh committed
963
%*                                                                      *
964 965 966
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
967
instDeclCtxt1 :: LHsType Name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
968
instDeclCtxt1 hs_inst_ty
969
  = inst_decl_ctxt (case unLoc hs_inst_ty of
Ian Lynagh's avatar
Ian Lynagh committed
970 971
                        HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
                        HsPredTy pred                    -> ppr pred
Ian Lynagh's avatar
Ian Lynagh committed
972 973
                        _                                -> ppr hs_inst_ty)     -- Don't expect this
instDeclCtxt2 :: Type -> SDoc
974 975
instDeclCtxt2 dfun_ty
  = inst_decl_ctxt (ppr (mkClassPred cls tys))
976
  where
977 978
    (_,_,cls,tys) = tcSplitDFunTy dfun_ty

Ian Lynagh's avatar
Ian Lynagh committed
979
inst_decl_ctxt :: SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
980
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
981

Ian Lynagh's avatar
Ian Lynagh committed
982
superClassCtxt :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
983
superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
984

Ian Lynagh's avatar
Ian Lynagh committed
985
atInstCtxt :: Name -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
986 987
atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
                  quotes (ppr name)
988

Ian Lynagh's avatar
Ian Lynagh committed
989
mustBeVarArgErr :: Type -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
990
mustBeVarArgErr ty =
Ian Lynagh's avatar
Ian Lynagh committed
991 992 993
  sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
        ptext (sLit "must be variables")
      , ptext (sLit "Instead of a variable, found") <+> ppr ty
994 995
      ]

Ian Lynagh's avatar
Ian Lynagh committed
996
wrongATArgErr :: Type -> Type -> SDoc
997
wrongATArgErr ty instTy =
Ian Lynagh's avatar
Ian Lynagh committed
998 999
  sep [ ptext (sLit "Type indexes must match class instance head")
      , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>
1000 1001
         ppr instTy
      ]
1002
\end{code}