Merge remote branch 'origin/master'
[ghc-hetmet.git] / compiler / typecheck / TcInstDcls.lhs
index da18ef1..954471f 100644 (file)
@@ -8,46 +8,54 @@ TcInstDecls: Typechecking instance declarations
 \begin{code}
 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
 
-#include "HsVersions.h"
-
 import HsSyn
 import TcBinds
 import TcTyClsDecls
 import TcClassDcl
-import TcRnMonad       
+import TcPat( addInlinePrags )
+import TcRnMonad
 import TcMType
 import TcType
+import BuildTyCl
 import Inst
 import InstEnv
 import FamInst
 import FamInstEnv
 import TcDeriv
 import TcEnv
+import RnSource ( addTcgDUs )
 import TcHsType
 import TcUnify
-import TcSimplify
+import MkCore  ( nO_METHOD_BINDING_ERROR_ID )
 import Type
 import Coercion
 import TyCon
 import DataCon
 import Class
 import Var
+import Pair
+import VarSet
+import CoreUtils  ( mkPiTypes )
+import CoreUnfold ( mkDFunUnfolding )
+import CoreSyn    ( Expr(Var), DFunArg(..), CoreExpr )
+import Id
 import MkId
 import Name
 import NameSet
 import DynFlags
 import SrcLoc
-import ListSetOps
 import Util
 import Outputable
 import Bag
 import BasicTypes
 import HscTypes
 import FastString
-
+import Maybes  ( orElse )
 import Data.Maybe
-import Control.Monad hiding (zipWithM_, mapAndUnzipM)
+import Control.Monad
 import Data.List
+
+#include "HsVersions.h"
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
@@ -60,157 +68,348 @@ 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.
 
-Here is the overall algorithm.
-Assume that we have an instance declaration
-
-    instance c => k (t tvs) where b
-
-\begin{enumerate}
-\item
-$LIE_c$ is the LIE for the context of class $c$
-\item
-$betas_bar$ is the free variables in the class method type, excluding the
-   class variable
-\item
-$LIE_cop$ is the LIE constraining a particular class method
-\item
-$tau_cop$ is the tau type of a class method
-\item
-$LIE_i$ is the LIE for the context of instance $i$
-\item
-$X$ is the instance constructor tycon
-\item
-$gammas_bar$ is the set of type variables of the instance
-\item
-$LIE_iop$ is the LIE for a particular class method instance
-\item
-$tau_iop$ is the tau type for this instance of a class method
-\item
-$alpha$ is the class variable
-\item
-$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
-\item
-$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
-\end{enumerate}
-
-ToDo: Update the list above with names actually in the code.
-
-\begin{enumerate}
-\item
-First, make the LIEs for the class and instance contexts, which means
-instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
-and make LIElistI and LIEI.
-\item
-Then process each method in turn.
-\item
-order the instance methods according to the ordering of the class methods
-\item
-express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
-\item
-Create final dictionary function from bindings generated already
-\begin{pseudocode}
-df = lambda inst_tyvars
-       lambda LIEI
-        let Bop1
-            Bop2
-            ...
-            Bopn
-        and dbinds_super
-             in <op1,op2,...,opn,sd1,...,sdm>
-\end{pseudocode}
-Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
-and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
-\end{enumerate}
+
+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"
+       -- The INLINE pragma comes from the user pragma
+       {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
+       op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
+       op1_i = /\a. \(d:C a). 
+              let this :: C [a]
+                  this = df_i a d
+                    -- Note [Subtle interaction of recursion and overlap]
+
+                  local_op1 :: forall b. Ix b => [a] -> b -> b
+                  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
+
+       op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) 
+
+       -- The dictionary function itself
+       {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
+       df_i :: forall a. C a -> C [a]
+       df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
+               -- But see Note [Default methods in instances]
+               -- We can't apply the type checker to the default-method call
+
+        -- Use a RULE to short-circuit applications of the class ops
+       {-# RULE "op1@C[a]" forall a, d:C a. 
+                            op1 [a] (df_i d) = op1_i a d #-}
+
+Note [Instances and loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* 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.
+
+* 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.  But this is OK: the recursion breaking happens by way of
+  a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
+  unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
+
+Note [ClassOp/DFun selection]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One thing we see a lot is stuff like
+    op2 (df d1 d2)
+where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
+'op2' and 'df' to get
+     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
+       MkD _ op2 _ _ _ -> op2
+And that will reduce to ($cop2 d1 d2) which is what we wanted.
+
+But it's tricky to make this work in practice, because it requires us to 
+inline both 'op2' and 'df'.  But neither is keen to inline without having
+seen the other's result; and it's very easy to get code bloat (from the 
+big intermediate) if you inline a bit too much.
+
+Instead we use a cunning trick.
+ * We arrange that 'df' and 'op2' NEVER inline.  
+
+ * We arrange that 'df' is ALWAYS defined in the sylised form
+      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
+
+ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
+   that lists its methods.
+
+ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
+   a suitable constructor application -- inlining df "on the fly" as it 
+   were.
+
+ * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
+   iff its argument satisfies exprIsConApp_maybe.  This is done in
+   MkId mkDictSelId
+
+ * We make 'df' CONLIKE, so that shared uses stil match; eg
+      let d = df d1 d2
+      in ...(op2 d)...(op1 d)...
+
+Note [Single-method classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the class has just one method (or, more accurately, just one element
+of {superclasses + methods}), then we use a different strategy.
+
+   class C a where op :: a -> a
+   instance C a => C [a] where op = <blah>
+
+We translate the class decl into a newtype, which just gives a
+top-level axiom. The "constructor" MkC expands to a cast, as does the
+class-op selector.
+
+   axiom Co:C a :: C a ~ (a->a)
+
+   op :: forall a. C a -> (a -> a)
+   op a d = d |> (Co:C a)
+
+   MkC :: forall a. (a->a) -> C a
+   MkC = /\a.\op. op |> (sym Co:C a)
+
+The clever RULE stuff doesn't work now, because ($df a d) isn't
+a constructor application, so exprIsConApp_maybe won't return 
+Just <blah>.
+
+Instead, we simply rely on the fact that casts are cheap:
+
+   $df :: forall a. C a => C [a]
+   {-# INLINE df #}  -- NB: INLINE this
+   $df = /\a. \d. MkC [a] ($cop_list a d)
+       = $cop_list |> forall a. C a -> (sym (Co:C [a]))
+
+   $cop_list :: forall a. C a => [a] -> [a]
+   $cop_list = <blah>
+
+So if we see
+   (op ($df a d))
+we'll inline 'op' and '$df', since both are simply casts, and
+good things happen.
+
+Why do we use this different strategy?  Because otherwise we
+end up with non-inlined dictionaries that look like
+    $df = $cop |> blah
+which adds an extra indirection to every use, which seems stupid.  See
+Trac #4138 for an example (although the regression reported there
+wasn't due to the indirction).
+
+There is an awkward wrinkle though: we want to be very 
+careful when we have
+    instance C a => C [a] where
+      {-# INLINE op #-}
+      op = ...
+then we'll get an INLINE pragma on $cop_list but it's important that
+$cop_list only inlines when it's applied to *two* arguments (the
+dictionary and the list argument).  So we nust not eta-expand $df
+above.  We ensure that this doesn't happen by putting an INLINE 
+pragma on the dfun itself; after all, it ends up being just a cast.
+
+There is one more dark corner to the INLINE story, even more deeply 
+buried.  Consider this (Trac #3772):
+
+    class DeepSeq a => C a where
+      gen :: Int -> a
+
+    instance C a => C [a] where
+      gen n = ...
+
+    class DeepSeq a where
+      deepSeq :: a -> b -> b
+
+    instance DeepSeq a => DeepSeq [a] where
+      {-# INLINE deepSeq #-}
+      deepSeq xs b = foldr deepSeq b xs
+
+That gives rise to these defns:
+
+    $cdeepSeq :: DeepSeq a -> [a] -> b -> b
+    -- User INLINE( 3 args )!
+    $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
+
+    $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
+    -- DFun (with auto INLINE pragma)
+    $fDeepSeq[] a d = $cdeepSeq a d |> blah
+
+    $cp1 a d :: C a => DeepSep [a]
+    -- We don't want to eta-expand this, lest
+    -- $cdeepSeq gets inlined in it!
+    $cp1 a d = $fDeepSep[] a (scsel a d)
+
+    $fC[] :: C a => C [a]
+    -- Ordinary DFun
+    $fC[] a d = MkC ($cp1 a d) ($cgen a d)
+
+Here $cp1 is the code that generates the superclass for C [a].  The
+issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
+and then $cdeepSeq will inline there, which is definitely wrong.  Like
+on the dfun, we solve this by adding an INLINE pragma to $cp1.
+
+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 = ...
+  instance 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
+treat the 'a' as an *existential* type variable, in the sense described
+by Note [Binding when looking up instances].  That is why isOverlappableTyVar
+responds True to an InstSkol, which is the kind of skolem we use in
+tcInstDecl2.
+
+
+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>.
+
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Extracting instance decls}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 Gather up the instance declarations from their various sources
 
 \begin{code}
-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
-          [InstInfo],          -- Source-code instance decls to process; 
-                               -- contains all dfuns for this module
-          HsValBinds Name)     -- Supporting bindings for derived instances
+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
+           [InstInfo Name],     -- Source-code instance decls to process;
+                                -- contains all dfuns for this module
+           HsValBinds Name)     -- Supporting bindings for derived instances
 
 tcInstDecls1 tycl_decls inst_decls deriv_decls
   = checkNoErrs $
     do {        -- Stop if addInstInfos etc discovers any errors
-               -- (they recover, so that we get more than one error each
-               -- round) 
-
-               -- (1) Do class instance declarations and instances of indexed
-               --     types 
-       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
-       ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
-       ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
-
-       ; let { (local_infos,
-               at_tycons)     = unzip local_info_tycons
-            ; local_info      = concat local_infos
-            ; at_idx_tycon    = concat at_tycons ++ catMaybes idx_tycons
-            ; 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
-       ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
-
-               -- (3) Instances from generic class declarations
+                -- (they recover, so that we get more than one error each
+                -- round)
+
+                -- (1) Do class and family instance declarations
+       ; idx_tycons        <- mapAndRecoverM (tcFamInstDecl TopLevel) $
+                                     filter (isFamInstDecl . unLoc) tycl_decls 
+       ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
+
+       ; let { (local_info,
+                at_tycons_s)   = unzip local_info_tycons
+             ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
+             ; clas_decls      = filter (isClassDecl . unLoc) tycl_decls
+             ; implicit_things = concatMap implicitTyThings at_idx_tycons
+            ; aux_binds       = mkRecSelBinds at_idx_tycons
+             }
+
+                -- (2) Add the tycons of indexed types and their implicit
+                --     tythings to the global environment
+       ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+
+                -- (3) Instances from generic class declarations
        ; generic_inst_info <- getGenericInstances clas_decls
 
-               -- Next, construct the instance environment so far, consisting
-               -- of 
-               --   a) local instance decls
-               --   b) generic instances
-               --   c) local family instance decls
-       ; addInsts local_info         $ do {
-       ; addInsts generic_inst_info  $ do {
-       ; addFamInsts at_idx_tycon    $ do {
-
-               -- (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
-       ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
-       ; addInsts deriv_inst_info   $ do {
-
-       ; gbl_env <- getGblEnv
-       ; returnM (gbl_env, 
-                 generic_inst_info ++ deriv_inst_info ++ local_info,
-                 deriv_binds) 
-    }}}}}}
-  where
-    -- Make sure that toplevel type instance are not for associated types.
-    -- !!!TODO: Need to perform this check for the TyThing of type functions,
-    --         too.
-    tcIdxTyInstDeclTL ldecl@(L loc decl) =
-      do { tything <- tcIdxTyInstDecl ldecl
-        ; setSrcSpan loc $
-            when (isAssocFamily tything) $
-              addErr $ assocInClassErr (tcdName decl)
-        ; return tything
-        }
-    isAssocFamily (Just (ATyCon tycon)) =
-      case tyConFamInst_maybe tycon of
-        Nothing       -> panic "isAssocFamily: no family?!?"
-       Just (fam, _) -> isTyConAssoc fam
-    isAssocFamily (Just _            ) = panic "isAssocFamily: no tycon?!?"
-    isAssocFamily Nothing               = False
-
-assocInClassErr name = 
-  ptext SLIT("Associated type") <+> quotes (ppr name) <+> 
-  ptext SLIT("must be inside a class instance")
-
-addInsts :: [InstInfo] -> TcM a -> TcM a
+                -- Next, construct the instance environment so far, consisting
+                -- of
+                --   (a) local instance decls
+                --   (b) generic instances
+                --   (c) local family instance decls
+       ; addInsts local_info         $
+         addInsts generic_inst_info  $
+         addFamInsts at_idx_tycons   $ do {
+
+                -- (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
+                -- NB: class instance declarations can contain derivings as
+                --     part of associated data type declarations
+        failIfErrsM            -- If the addInsts stuff gave any errors, don't
+                               -- try the deriving stuff, becuase that may give
+                               -- more errors still
+       ; (deriv_inst_info, deriv_binds, deriv_dus) 
+              <- tcDeriving tycl_decls inst_decls deriv_decls
+       ; gbl_env <- addInsts deriv_inst_info getGblEnv
+       ; return ( addTcgDUs gbl_env deriv_dus,
+                  generic_inst_info ++ deriv_inst_info ++ local_info,
+                  aux_binds `plusHsValBinds` deriv_binds)
+    }}}
+
+addInsts :: [InstInfo Name] -> TcM a -> TcM a
 addInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 
@@ -219,645 +418,1062 @@ addFamInsts tycons thing_inside
   = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
   where
     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
-    mkLocalFamInstTyThing tything       = pprPanic "TcInstDcls.addFamInsts"
-                                                   (ppr tything)
+    mkLocalFamInstTyThing tything        = pprPanic "TcInstDcls.addFamInsts"
+                                                    (ppr tything)
 \end{code}
 
 \begin{code}
-tcLocalInstDecl1 :: LInstDecl Name 
-                -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
-       -- A source-file instance declaration
-       -- Type-check all the stuff before the "where"
-       --
-       -- We check for respectable instance type, and context
-tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
-  =    -- Prime error recovery, set source location
-    recoverM (returnM ([], []))                $
-    setSrcSpan loc                     $
-    addErrCtxt (instDeclCtxt1 poly_ty) $
-
-    do { is_boot <- tcIsHsBoot
-       ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
-                 badBootDeclErr
-
-       ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
-       
-       -- Next, process any associated types.
-       ; idx_tycons <- mappM tcIdxTyInstDecl ats
-
-       -- Now, check the validity of the instance.
-       ; (clas, inst_tys) <- checkValidInstHead tau
-       ; checkValidInstance tyvars theta clas inst_tys
-       ; checkValidAndMissingATs clas (tyvars, inst_tys) 
-                                 (zip ats idx_tycons)
-
-       -- Finally, construct the Core representation of the instance.
-       -- (This no longer includes the associated types.)
-       ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
-       ; overlap_flag <- getOverlapFlag
-       ; let dfun           = mkDictFunId dfun_name tyvars theta clas inst_tys
-             ispec          = mkLocalInstance dfun overlap_flag
-
-       ; return ([InstInfo { iSpec  = ispec, 
-                             iBinds = VanillaInst binds uprags }],
-                 catMaybes idx_tycons)
+tcLocalInstDecl1 :: LInstDecl Name
+                 -> TcM (InstInfo Name, [TyThing])
+        -- A source-file instance declaration
+        -- Type-check all the stuff before the "where"
+        --
+        -- We check for respectable instance type, and context
+tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
+  = setSrcSpan loc                     $
+    addErrCtxt (instDeclCtxt1 poly_ty)  $
+
+    do  { is_boot <- tcIsHsBoot
+        ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
+                  badBootDeclErr
+
+        ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
+        ; checkValidInstance poly_ty tyvars theta clas inst_tys
+
+        -- Next, process any associated types.
+        ; idx_tycons <- recoverM (return []) $
+                    do { idx_tycons <- checkNoErrs $ 
+                                        mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
+                       ; checkValidAndMissingATs clas (tyvars, inst_tys)
+                                                 (zip ats idx_tycons)
+                       ; return idx_tycons }
+
+        -- Finally, construct the Core representation of the instance.
+        -- (This no longer includes the associated types.)
+        ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
+               -- Dfun location is that of instance *header*
+        ; overlap_flag <- getOverlapFlag
+        ; let (eq_theta,dict_theta) = partition isEqPred theta
+              theta'         = eq_theta ++ dict_theta
+              dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
+              ispec          = mkLocalInstance dfun overlap_flag
+
+        ; return (InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False },
+                  idx_tycons)
         }
   where
     -- 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
-                           -> ([TyVar], [TcType])     -- instance types
-                           -> [(LTyClDecl Name,       -- source form of AT
-                                Maybe TyThing)]       -- Core form of AT
-                           -> TcM ()
+                            -> ([TyVar], [TcType])     -- instance types
+                            -> [(LTyClDecl Name,       -- source form of AT
+                                 TyThing)]            -- Core form of AT
+                            -> TcM ()
     checkValidAndMissingATs clas inst_tys ats
       = do { -- Issue a warning for each class AT that is not defined in this
-            -- instance.
-          ; let class_ats   = map tyConName (classATs clas)
+             -- instance.
+           ; let class_ats   = map tyConName (classATs clas)
                  defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
-                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
-          }
-
-    checkIndexes _    _        (hsAT, Nothing)             = 
-      return ()           -- skip, we already had an error here
-    checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = 
+                 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
+           }
+
+    checkIndexes clas inst_tys (hsAT, ATyCon tycon)
 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
-      checkIndexes' clas inst_tys hsAT 
-                   (tyConTyVars tycon, 
-                    snd . fromJust . tyConFamInst_maybe $ tycon)
+      = checkIndexes' clas inst_tys hsAT
+                      (tyConTyVars tycon,
+                       snd . fromJust . tyConFamInst_maybe $ tycon)
     checkIndexes _ _ _ = panic "checkIndexes"
 
     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
       = let atName = tcdName . unLoc $ hsAT
-       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.)
+        in
+        setSrcSpan (getLoc hsAT)       $
+        addErrCtxt (atInstCtxt atName) $
+        case find ((atName ==) . tyConName) (classATs clas) of
+          Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
+          Just atycon ->
+                -- 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 (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 
+               -- e.g.    class C a b c where 
+               --           data D b a :: * -> *           -- NB (1) b a, omits c
+               --         instance C [x] Bool Char where 
+               --           data D Bool [x] v = MkD x [v]  -- NB (2) v
+               --                -- NB (3) the x in 'instance C...' have differnt
+               --                --        Names to x's in 'data D...'
+                --
+                -- 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 poss :: [Int]
+                    -- For *associated* type families, gives the position
+                    -- of that 'TyVar' in the class argument list (0-indexed)
+                   -- e.g.  class C a b c where { type F c a :: *->* }
+                   --       Then we get Just [2,0]
+                   poss = catMaybes [ tv `elemIndex` classTyVars clas 
+                                     | tv <- tyConTyVars atycon]
+                       -- We will get Nothings for the "extra" type 
+                       -- variables in an associated data type
+                       -- e.g. class C a where { data D a :: *->* }
+                       -- here D gets arity 2 and has two tyvars
+
+                    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
       | isTyVarTy ty         = return ()
       | otherwise            = addErrTc $ mustBeVarArgErr ty
-    checkIndex ty (Just instTy) 
-      | ty `tcEqType` instTy = return ()
-      | otherwise            = addErrTc $ wrongATArgErr ty instTy
+    checkIndex ty (Just instTy)
+      | ty `eqType` instTy = return ()
+      | otherwise          = addErrTc $ wrongATArgErr ty instTy
 
-    listToNameSet = addListToNameSet emptyNameSet 
+    listToNameSet = addListToNameSet emptyNameSet
 
     substSameTyVar []       _            = emptyTvSubst
-    substSameTyVar (tv:tvs) replacingTvs = 
+    substSameTyVar (tv:tvs) replacingTvs =
       let replacement = case find (tv `sameLexeme`) replacingTvs of
-                         Nothing  -> mkTyVarTy tv
-                         Just rtv -> mkTyVarTy rtv
+                        Nothing  -> mkTyVarTy tv
+                        Just rtv -> mkTyVarTy rtv
           --
-          tv1 `sameLexeme` tv2 = 
-           nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
+          tv1 `sameLexeme` tv2 =
+            nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
       in
-      extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+      TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{Type-checking instance declarations, pass 2}
+               Type checking family instances
 %*                                                                     *
 %************************************************************************
 
+Family instances are somewhat of a hybrid.  They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+
 \begin{code}
-tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] 
-            -> TcM (LHsBinds Id, TcLclEnv)
--- (a) From each class declaration, 
---     generate any default-method bindings
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl top_lvl (L loc decl)
+  =    -- Prime error recovery, set source location
+    setSrcSpan loc                             $
+    tcAddDeclCtxt decl                         $
+    do { -- type family instances require -XTypeFamilies
+        -- and can't (currently) be in an hs-boot file
+       ; type_families <- xoptM Opt_TypeFamilies
+       ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?
+       ; checkTc type_families $ badFamInstDecl (tcdLName decl)
+       ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+        -- Perform kind and type checking
+       ; tc <- tcFamInstDecl1 decl
+       ; checkValidTyCon tc    -- Remember to check validity;
+                               -- no recursion to worry about here
+
+       -- Check that toplevel type instances are not for associated types.
+       ; when (isTopLevel top_lvl && isAssocFamily tc)
+              (addErr $ assocInClassErr (tcdName decl))
+
+       ; return (ATyCon tc) }
+
+isAssocFamily :: TyCon -> Bool -- Is an assocaited type
+isAssocFamily tycon
+  = case tyConFamInst_maybe tycon of
+          Nothing       -> panic "isAssocFamily: no family?!?"
+          Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+   ptext (sLit "must be inside a class instance")
+
+
+
+tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
+
+  -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
+  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+    do { -- check that the family declaration is for a synonym
+         checkTc (isFamilyTyCon family) (notFamily family)
+       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
+
+       ; -- (1) kind check the right-hand side of the type equation
+       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+                         -- ToDo: the ExpKind could be better
+
+         -- we need the exact same number of type parameters as the family
+         -- declaration 
+       ; let famArity = tyConArity family
+       ; checkTc (length k_typats == famArity) $ 
+           wrongNumberOfParmsErr famArity
+
+         -- (2) type check type equation
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
+       ; t_typats <- mapM tcHsKindedType k_typats
+       ; t_rhs    <- tcHsKindedType k_rhs
+
+         -- (3) check the well-formedness of the instance
+       ; checkValidTypeInst t_typats t_rhs
+
+         -- (4) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+       ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
+                       (typeKind t_rhs) 
+                       NoParentTyCon (Just (family, t_typats))
+       }}
+
+  -- "newtype instance" and "data instance"
+tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
+                            tcdCons = cons})
+  = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
+    do { -- check that the family declaration is for the right kind
+         checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
+       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
+
+       ; -- (1) kind check the data declaration as usual
+       ; k_decl <- kcDataDecl decl k_tvs
+       ; let k_ctxt = tcdCtxt k_decl
+            k_cons = tcdCons k_decl
+
+         -- result kind must be '*' (otherwise, we have too few patterns)
+       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
+
+         -- (2) type check indexed data type declaration
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
+       ; unbox_strict <- doptM Opt_UnboxStrictFields
+
+         -- kind check the type indexes and the context
+       ; t_typats     <- mapM tcHsKindedType k_typats
+       ; stupid_theta <- tcHsKindedContext k_ctxt
+
+         -- (3) Check that
+         --     (a) left-hand side contains no type family applications
+         --         (vanilla synonyms are fine, though, and we checked for
+         --         foralls earlier)
+       ; mapM_ checkTyFamFreeness t_typats
+
+       ; dataDeclChecks tc_name new_or_data stupid_theta k_cons
+
+         -- (4) construct representation tycon
+       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+       ; let ex_ok = True      -- Existentials ok for type families!
+       ; fixM (\ rep_tycon -> do 
+            { let orig_res_ty = mkTyConApp fam_tycon t_typats
+            ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
+                                      (t_tvs, orig_res_ty) k_cons
+            ; tc_rhs <-
+                case new_or_data of
+                  DataType -> return (mkDataTyConRhs data_cons)
+                  NewType  -> ASSERT( not (null data_cons) )
+                              mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
+            ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
+                            False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+                 -- We always assume that indexed types are recursive.  Why?
+                 -- (1) Due to their open nature, we can never be sure that a
+                 -- further instance might not introduce a new recursive
+                 -- dependency.  (2) They are always valid loop breakers as
+                 -- they involve a coercion.
+            })
+       }}
+       where
+        h98_syntax = case cons of      -- All constructors have same shape
+                       L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
+                       _ -> True
+
+tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
+
+-- Kind checking of indexed types
+-- -
+
+-- Kind check type patterns and kind annotate the embedded type variables.
+--
+-- * Here we check that a type instance matches its kind signature, but we do
+--   not check whether there is a pattern for each type index; the latter
+--   check is only required for type synonym instances.
+
+kcIdxTyPats :: TyClDecl Name
+           -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
+              -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
+           -> TcM a
+kcIdxTyPats decl thing_inside
+  = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
+    do { let tc_name = tcdLName decl
+       ; fam_tycon <- tcLookupLocatedTyCon tc_name
+       ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
+            ; hs_typats        = fromJust $ tcdTyPats decl }
+
+         -- we may not have more parameters than the kind indicates
+       ; checkTc (length kinds >= length hs_typats) $
+          tooManyParmsErr (tcdLName decl)
+
+         -- type functions can have a higher-kinded result
+       ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
+       ; typats <- zipWithM kcCheckLHsType hs_typats 
+                                   [ EK kind (EkArg (ppr tc_name) n) 
+                            | (kind,n) <- kinds `zip` [1..]]
+       ; thing_inside tvs typats resultKind fam_tycon
+       }
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
+      Type-checking instance declarations, pass 2
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
+             -> TcM (LHsBinds Id)
+-- (a) From each class declaration,
+--      generate any default-method bindings
 -- (b) From each instance decl
---     generate the dfun binding
+--      generate the dfun binding
 
 tcInstDecls2 tycl_decls inst_decls
-  = 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 <- mappM tcInstDecl2 inst_decls
-
-               -- Done
-       ; let binds = unionManyBags dm_binds_s `unionBags` 
-                     unionManyBags inst_binds_s
-       ; tcl_env <- getLclEnv          -- Default method Ids in here
-       ; returnM (binds, tcl_env) }
+  = do  { -- (a) Default methods from class decls
+          let class_decls = filter (isClassDecl . unLoc) tycl_decls
+        ; dm_binds_s <- mapM tcClassDecl2 class_decls
+        ; let dm_binds = unionManyBags dm_binds_s
+                                    
+          -- (b) instance declarations
+       ; let dm_ids = collectHsBindsBinders dm_binds
+             -- Add the default method Ids (again)
+             -- See Note [Default methods and instances]
+        ; inst_binds_s <- tcExtendIdEnv dm_ids $
+                          mapM tcInstDecl2 inst_decls
+
+          -- Done
+        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
 \end{code}
 
-======= New documentation starts here (Sept 92)         ==============
-
-The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
-the dictionary function for this instance declaration. For example
-\begin{verbatim}
-       instance Foo a => Foo [a] where
-               op1 x = ...
-               op2 y = ...
-\end{verbatim}
-might generate something like
-\begin{verbatim}
-       dfun.Foo.List dFoo_a = let op1 x = ...
-                                  op2 y = ...
-                              in
-                                  Dict [op1, op2]
-\end{verbatim}
-
-HOWEVER, if the instance decl has no context, then it returns a
-bigger @HsBinds@ with declarations for each method.  For example
-\begin{verbatim}
-       instance Foo [a] where
-               op1 x = ...
-               op2 y = ...
-\end{verbatim}
-might produce
-\begin{verbatim}
-       dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
-       const.Foo.op1.List a x = ...
-       const.Foo.op2.List a y = ...
-\end{verbatim}
-This group may be mutually recursive, because (for example) there may
-be no method supplied for op2 in which case we'll get
-\begin{verbatim}
-       const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
-\end{verbatim}
-that is, the default method applied to the dictionary at this type.
-
-What we actually produce in either case is:
-
-       AbsBinds [a] [dfun_theta_dicts]
-                [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
-                { d = (sd1,sd2, ..., op1, op2, ...)
-                  op1 = ...
-                  op2 = ...
-                }
-
-The "maybe" says that we only ask AbsBinds to make global constant methods
-if the dfun_theta is empty.
-
-               
-For an instance declaration, say,
-
-       instance (C1 a, C2 b) => C (T a b) where
-               ...
-
-where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
-function whose type is
-
-       (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
-
-Notice that we pass it the superclass dictionaries at the instance type; this
-is the ``Mark Jones optimisation''.  The stuff before the "=>" here
-is the @dfun_theta@ below.
-
-First comes the easy case of a non-local instance decl.
+See Note [Default methods and instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The default method Ids are already in the type environment (see Note
+[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
+don't have their InlinePragmas yet.  Usually that would not matter,
+because the simplifier propagates information from binding site to
+use.  But, unusually, when compiling instance decls we *copy* the
+INLINE pragma from the default method to the method for that
+particular operation (see Note [INLINE and default methods] below).
 
+So right here in tcInstDecl2 we must re-extend the type envt with
+the default method Ids replete with their INLINE pragmas.  Urk.
 
 \begin{code}
-tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
--- Returns a binding for the dfun
 
-------------------------
--- Derived newtype instances; surprisingly tricky!
+tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
+            -- Returns a binding for the dfun
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
+  = recoverM (return emptyLHsBinds)             $
+    setSrcSpan loc                              $
+    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
+    do {  -- Instantiate the instance decl with skolem constants
+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+                     -- We instantiate the dfun_id with superSkolems.
+                     -- See Note [Subtle interaction of recursion and overlap]
+                     -- and Note [Binding when looking up instances]
+       ; let (clas, inst_tys) = tcSplitDFunHead inst_head
+             (class_tyvars, sc_theta, _, op_items) = classBigSig clas
+             sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
+             n_ty_args = length inst_tyvars
+             n_silent  = dfunNSilent dfun_id
+             (silent_theta, orig_theta) = splitAt n_silent dfun_theta
+
+       ; silent_ev_vars <- mapM newSilentGiven silent_theta
+       ; orig_ev_vars   <- newEvVars orig_theta
+       ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
+
+       ; (sc_dicts, sc_args)
+             <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
+
+       -- Check that any superclasses gotten from a silent arguemnt
+       -- can be deduced from the originally-specified dfun arguments
+       ; ct_loc <- getCtLoc ScOrigin
+       ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
+              emitFlats $ listToBag $
+              [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
+
+       -- Deal with 'SPECIALISE instance' pragmas
+       -- See Note [SPECIALISE instance pragmas]
+       ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
+
+        -- Typecheck the methods
+       ; (meth_ids, meth_binds) 
+           <- tcExtendTyVarEnv inst_tyvars $
+                -- The 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!
+              tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
+                                inst_tys spec_info
+                                op_items ibinds
+
+       -- Create the result bindings
+       ; self_dict <- newEvVar (ClassP clas inst_tys)
+       ; let class_tc      = classTyCon clas
+             [dict_constr] = tyConDataCons class_tc
+             dict_bind     = mkVarBind self_dict dict_rhs
+             dict_rhs      = foldl mk_app inst_constr $
+                             map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
+             inst_constr   = L loc $ wrapId (mkWpTyApps inst_tys)
+                                            (dataConWrapId dict_constr)
+                     -- 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.
+
+             mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
+             mk_app fun arg = L loc (HsApp fun (L loc arg))
+
+             arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
+
+               -- Do not inline the dfun; instead give it a magic DFunFunfolding
+               -- See Note [ClassOp/DFun selection]
+               -- See also note [Single-method classes]
+             dfun_id_w_fun
+                | isNewTyCon class_tc
+                = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+                | otherwise
+                = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
+                          `setInlinePragma` dfunInlinePragma
+             meth_args = map (DFunPolyArg . Var) meth_ids
+
+             main_bind = AbsBinds { abs_tvs = inst_tyvars
+                                  , abs_ev_vars = dfun_ev_vars
+                                  , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
+                                                    SpecPrags spec_inst_prags)]
+                                  , abs_ev_binds = emptyTcEvBinds
+                                  , abs_binds = unitBag dict_bind }
+
+       ; return (unitBag (L loc main_bind) `unionBags`
+                 listToBag meth_binds)
+       }
+ where
+   skol_info = InstSkol         
+   dfun_ty   = idType dfun_id
+   dfun_id   = instanceDFunId ispec
+   loc       = getSrcSpan dfun_id
+
+------------------------------
+tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
+-- All superclasses should be either
+--   (a) be one of the arguments to the dfun, of
+--   (b) be a constant, soluble at top level
+tcSuperClass n_ty_args ev_vars pred
+  | Just (ev, i) <- find n_ty_args ev_vars
+  = return (ev, DFunLamArg i)
+  | otherwise
+  = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)       -- Constant!
+    do { sc_dict  <- emitWanted ScOrigin pred
+       ; return (sc_dict, DFunConstArg (Var sc_dict)) }
+  where
+    find _ [] = Nothing
+    find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
+                    | otherwise                  = find (i+1) evs
+
+------------------------------
+tcSpecInstPrags :: DFunId -> InstBindings Name
+                -> TcM ([Located TcSpecPrag], PragFun)
+tcSpecInstPrags _ (NewTypeDerived {})
+  = return ([], \_ -> [])
+tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+                            filter isSpecInstLSig uprags
+            -- The filter removes the pragmas for methods
+       ; return (spec_inst_prags, mkPragFun uprags binds) }
+\end{code}
+
+Note [Silent Superclass Arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following (extreme) situation:
+        class C a => D a where ...
+        instance D [a] => D [a] where ...
+Although this looks wrong (assume D [a] to prove D [a]), it is only a
+more extreme case of what happens with recursive dictionaries.
+
+To implement the dfun we must generate code for the superclass C [a],
+which we can get by superclass selection from the supplied argument!
+So we’d generate:
+       dfun :: forall a. D [a] -> D [a]
+       dfun = \d::D [a] -> MkD (scsel d) ..
+
+However this means that if we later encounter a situation where
+we have a [Wanted] dw::D [a] we could solve it thus:
+     dw := dfun dw
+Although recursive, this binding would pass the TcSMonadisGoodRecEv
+check because it appears as guarded.  But in reality, it will make a
+bottom superclass. The trouble is that isGoodRecEv can't "see" the
+superclass-selection inside dfun.
+
+Our solution to this problem is to change the way â€˜dfuns’ are created
+for instances, so that we pass as first arguments to the dfun some
+``silent superclass arguments’’, which are the immediate superclasses
+of the dictionary we are trying to construct. In our example:
+       dfun :: forall a. (C [a], D [a] -> D [a]
+       dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
+
+This gives us:
+
+     -----------------------------------------------------------
+     DFun Superclass Invariant
+     ~~~~~~~~~~~~~~~~~~~~~~~~
+     In the body of a DFun, every superclass argument to the
+     returned dictionary is
+       either   * one of the arguments of the DFun,
+       or       * constant, bound at top level
+     -----------------------------------------------------------
+
+This means that no superclass is hidden inside a dfun application, so
+the counting argument in isGoodRecEv (more dfun calls than superclass
+selections) works correctly.
+
+The extra arguments required to satisfy the DFun Superclass Invariant
+always come first, and are called the "silent" arguments.  DFun types
+are built (only) by MkId.mkDictFunId, so that is where we decide
+what silent arguments are to be added.
+
+This net effect is that it is safe to treat a dfun application as
+wrapping a dictionary constructor around its arguments (in particular,
+a dfun never picks superclasses from the arguments under the dictionary
+constructor).
+
+In our example, if we had  [Wanted] dw :: D [a] we would get via the instance:
+    dw := dfun d1 d2
+    [Wanted] (d1 :: C [a])
+    [Wanted] (d2 :: D [a])
+    [Derived] (d :: D [a])
+    [Derived] (scd :: C [a])   scd  := scsel d
+    [Derived] (scd2 :: C [a])  scd2 := scsel d2
+
+And now, though we *can* solve: 
+     d2 := dw
+we will get an isGoodRecEv failure when we try to solve:
+    d1 := scsel d 
+ or
+    d1 := scsel d2 
+
+Test case SCLoop tests this fix. 
+         
+Note [SPECIALISE instance pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   instance (Ix a, Ix b) => Ix (a,b) where
+     {-# SPECIALISE instance Ix (Int,Int) #-}
+     range (x,y) = ...
+
+We do *not* want to make a specialised version of the dictionary
+function.  Rather, we want specialised versions of each method.
+Thus we should generate something like this:
+
+  $dfIx :: (Ix a, Ix x) => Ix (a,b)
+  {- DFUN [$crange, ...] -}
+  $dfIx da db = Ix ($crange da db) (...other methods...)
+
+  $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
+  {- DFUN [$crangePair, ...] -}
+  $dfIxPair = Ix ($crangePair da db) (...other methods...)
+
+  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
+  $crange da db = <blah>
+
+  {-# RULE  range ($dfIx da db) = $crange da db #-}
+
+Note that  
+
+  * The RULE is unaffected by the specialisation.  We don't want to
+    specialise $dfIx, because then it would need a specialised RULE
+    which is a pain.  The single RULE works fine at all specialisations.
+    See Note [How instance declarations are translated] above
+
+  * Instead, we want to specialise the *method*, $crange
+
+In practice, rather than faking up a SPECIALISE pragama for each
+method (which is painful, since we'd have to figure out its
+specialised type), we call tcSpecPrag *as if* were going to specialise
+$dfIx -- you can see that in the call to tcSpecInst.  That generates a
+SpecPrag which, as it turns out, can be used unchanged for each method.
+The "it turns out" bit is delicate, but it works fine!
+
+\begin{code}
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
+tcSpecInst dfun_id prag@(SpecInstSig hs_ty) 
+  = addErrCtxt (spec_ctxt prag) $
+    do  { let name = idName dfun_id
+        ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
+        ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
+
+        ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
+                             (idType dfun_id) spec_dfun_ty
+        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
+  where
+    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+
+tcSpecInst _  _ = panic "tcSpecInst"
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+      Type-checking an instance method
+%*                                                                      *
+%************************************************************************
+
+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
+
+\begin{code}
+tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
+                  -> [EvVar]
+                 -> [TcType]
+                  -> ([Located TcSpecPrag], PragFun)
+                 -> [(Id, DefMeth)]
+                  -> InstBindings Name 
+                 -> TcM ([Id], [LHsBind Id])
+       -- The returned inst_meth_ids all have types starting
+       --      forall tvs. theta => ...
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
+                  (spec_inst_prags, prag_fn)
+                  op_items (VanillaInst binds _ standalone_deriv)
+  = mapAndUnzipM tc_item op_items
+  where
+    ----------------------
+    tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
+    tc_item (sel_id, dm_info)
+      = case findMethodBind (idName sel_id) binds of
+           Just user_bind -> tc_body sel_id standalone_deriv user_bind
+           Nothing        -> tc_default sel_id dm_info
+
+    ----------------------
+    tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
+    tc_body sel_id generated_code rn_bind 
+      = add_meth_ctxt sel_id generated_code rn_bind $
+        do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
+                                                   inst_tys sel_id
+           ; let prags = prag_fn (idName sel_id)
+           ; meth_id1 <- addInlinePrags meth_id prags
+           ; spec_prags <- tcSpecPrags meth_id1 prags
+           ; bind <- tcInstanceMethodBody InstSkol
+                          tyvars dfun_ev_vars
+                          meth_id1 local_meth_id meth_sig_fn 
+                          (mk_meth_spec_prags meth_id1 spec_prags)
+                          rn_bind 
+           ; return (meth_id1, bind) }
+
+    ----------------------
+    tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+    tc_default sel_id GenDefMeth    -- Derivable type classes stuff
+      = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
+           ; tc_body sel_id False {- Not generated code? -} meth_bind }
+         
+    tc_default sel_id NoDefMeth            -- No default method at all
+      = do { warnMissingMethod sel_id
+          ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars 
+                                         inst_tys sel_id
+           ; return (meth_id, mkVarBind meth_id $ 
+                              mkLHsWrap lam_wrapper error_rhs) }
+      where
+       error_rhs    = L loc $ HsApp error_fun error_msg
+       error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
+       error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+       meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
+       error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+        lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+
+    tc_default sel_id (DefMeth dm_name)        -- A polymorphic default method
+      = do {   -- Build the typechecked version directly, 
+                -- without calling typecheck_method; 
+                -- see Note [Default methods in instances]
+                 -- Generate   /\as.\ds. let self = df as ds
+                 --                      in $dm inst_tys self
+                -- The 'let' is necessary only because HsSyn doesn't allow
+                -- you to apply a function to a dictionary *expression*.
+
+           ; self_dict <- newEvVar (ClassP clas inst_tys)
+           ; let self_ev_bind = EvBind self_dict $
+                                EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
+
+           ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
+                                                   inst_tys sel_id
+           ; dm_id <- tcLookupId dm_name
+           ; let dm_inline_prag = idInlinePragma dm_id
+                 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
+                        HsVar dm_id 
+
+                meth_bind = L loc $ VarBind { var_id = local_meth_id
+                                             , var_rhs = L loc rhs 
+                                             , var_inline = False }
+                 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
+                           -- Copy the inline pragma (if any) from the default
+                           -- method to this version. Note [INLINE and default methods]
+                           
+                 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars =  dfun_ev_vars
+                                 , abs_exports = [( tyvars, meth_id1, local_meth_id
+                                                  , mk_meth_spec_prags meth_id1 [])]
+                                 , abs_ev_binds = EvBinds (unitBag self_ev_bind)
+                                 , abs_binds    = unitBag meth_bind }
+            -- Default methods in an instance declaration can't have their own 
+            -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
+            -- currently they are rejected with 
+            --           "INLINE pragma lacks an accompanying binding"
+
+           ; return (meth_id1, L loc bind) } 
+
+    ----------------------
+    mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
+       -- Adapt the SPECIALISE pragmas to work for this method Id
+        -- There are two sources: 
+        --   * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
+        --     These ones have the dfun inside, but [perhaps surprisingly] 
+        --     the correct wrapper
+        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+    mk_meth_spec_prags meth_id spec_prags_for_me
+      = SpecPrags (spec_prags_for_me ++ 
+                   [ L loc (SpecPrag meth_id wrap inl)
+                  | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
+   
+    loc = getSrcSpan dfun_id
+    meth_sig_fn _ = Just ([],loc)      -- The 'Just' says "yes, there's a type sig"
+       -- But there are no scoped type variables from local_method_id
+       -- Only the ones from the instance decl itself, which are already
+       -- in scope.  Example:
+       --      class C a where { op :: forall b. Eq b => ... }
+       --      instance C [c] where { op = <rhs> }
+       -- In <rhs>, 'c' is scope but 'b' is not!
+
+        -- For instance decls that come from standalone deriving clauses
+       -- we want to print out the full source code if there's an error
+       -- because otherwise the user won't see the code at all
+    add_meth_ctxt sel_id generated_code rn_bind thing 
+      | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
+      | otherwise      = thing
+
+
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
+                  _ op_items (NewTypeDerived coi _)
+
+-- Running example:
+--   class Show b => Foo a b where
+--     op :: a -> b -> b
+--   newtype N a = MkN (Tree [a]) 
+--   deriving instance (Show p, Foo Int p) => Foo Int (N p)
+--              -- NB: standalone deriving clause means
+--              --     that the contex is user-specified
+-- Hence op :: forall a b. Foo a b => a -> b -> b
 --
--- In the case of a newtype, things are rather easy
---     class Show a => Foo a b where ...
---     newtype T a = MkT (Tree [a]) deriving( Foo Int )
--- The newtype gives an FC axiom looking like
---     axiom CoT a ::  T a :=: Tree [a]
---   (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
+-- We're going to make an instance like
+--   instance (Show p, Foo Int p) => Foo Int (N p)
+--      op = $copT
 --
--- So all need is to generate a binding looking like: 
---     dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
---     dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
---               case df `cast` (Foo Int (sym (CoT a))) of
---                  Foo _ op1 .. opn -> Foo ds op1 .. opn
+--   $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
+--   $copT p (d1:Show p) (d2:Foo Int p) 
+--     = op Int (Tree [p]) rep_d |> op_co
+--     where 
+--       rep_d :: Foo Int (Tree [p]) = ...d1...d2...
+--       op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
+-- We get op_co by substituting [Int/a] and [co/b] in type for op
+-- where co : [p] ~ T p
 --
--- If there are no superclasses, matters are simpler, because we don't need the case
--- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
-  = 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
-
-       ; inst_loc <- getInstLoc origin
-       ; (rep_dict_id : sc_dict_ids, wrap_fn, sc_binds)
-               <- make_wrapper inst_loc tvs theta mb_preds
-               -- Here, we are relying on the order of dictionary 
-               -- arguments built by NewTypeDerived in TcDeriv; 
-               -- namely, that the rep_dict_id comes first
-          
-        ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
-             cls_tycon           = classTyCon cls
-             the_coercion        = make_coercion cls_tycon cls_inst_tys
-              coerced_rep_dict           = mkHsWrap the_coercion (HsVar rep_dict_id)
-
-       ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
-              
-        ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) }
+-- Notice that the dictionary bindings "..d1..d2.." must be generated
+-- by the constraint solver, since the <context> may be
+-- user-specified.
+
+  = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
+                        emitWanted ScOrigin rep_pred
+                         
+       ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
   where
+     loc = getSrcSpan dfun_id
+
+     inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
+     Just (init_inst_tys, _) = snocView inst_tys
+     rep_ty   = pFst (coercionKind co)  -- [p]
+     rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
+
+     -- co : [p] ~ T p
+     co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $
+          mkSymCo coi
+
+     ----------------
+     tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
+     tc_item (rep_ev_binds, rep_d) (sel_id, _)
+       = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
+                                                    inst_tys sel_id
+
+            ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
+                  meth_bind = VarBind { var_id = local_meth_id
+                                      , var_rhs = L loc meth_rhs
+                                     , var_inline = False }
+
+                 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+                                   , abs_exports = [(tyvars, meth_id, 
+                                                     local_meth_id, noSpecPrags)]
+                                  , abs_ev_binds = rep_ev_binds
+                                   , abs_binds = unitBag $ L loc meth_bind }
+
+            ; return (meth_id, L loc bind) }
+
+     ----------------
+     mk_op_wrapper :: Id -> EvVar -> HsWrapper
+     mk_op_wrapper sel_id rep_d 
+       = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
+                               local_meth_ty)
+         <.> WpEvApp (EvId rep_d)
+         <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) 
+       where
+         (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
+         (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
+                              `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
+
+----------------------
+mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
+  = do  { uniq <- newUnique
+       ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
+       ; local_meth_name <- newLocalName sel_name
+                 -- Base the local_meth_name on the selector name, becuase
+                 -- type errors from tcInstanceMethodBody come from here
+
+       ; let meth_id       = mkLocalId meth_name meth_ty
+             local_meth_id = mkLocalId local_meth_name local_meth_ty
+        ; return (meth_id, local_meth_id) }
+  where
+    local_meth_ty = instantiateMethod clas sel_id inst_tys
+    meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
+    sel_name = idName sel_id
+
+----------------------
+wrapId :: HsWrapper -> id -> HsExpr id
+wrapId wrapper id = mkHsWrap wrapper (HsVar id)
+
+derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
+derivBindCtxt sel_id clas tys _bind
+   = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
+          , nest 2 (ptext (sLit "in a standalone derived instance for")
+                   <+> quotes (pprClassPred clas tys) <> colon)
+          , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
+
+-- Too voluminous
+--       , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
+
+warnMissingMethod :: Id -> TcM ()
+warnMissingMethod sel_id
+  = do { warn <- doptM Opt_WarnMissingMethods          
+       ; warnTc (warn  -- Warn only if -fwarn-missing-methods
+                 && not (startsWithUnderscore (getOccName sel_id)))
+                                       -- Don't warn about _foo methods
+               (ptext (sLit "No explicit method nor default method for")
+                 <+> quotes (ppr sel_id)) }
+\end{code}
 
-      -----------------------
-      --       make_wrapper
-      -- We distinguish two cases:
-      -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant,
-      --     and the new dict can just be a constant
-      --       (mb_preds = Just preds)
-      -- (b) there are tyvars, so we must make a dict *fun*
-      --       (mb_preds = Nothing)
-      -- See the defn of NewTypeDerived for the meaning of mb_preds
-    make_wrapper inst_loc tvs theta (Just preds)       -- Case (a)
-      = ASSERT( null tvs && null theta )
-       do { dicts <- newDictBndrs inst_loc preds
-          ; sc_binds <- addErrCtxt superClassCtxt $
-                        tcSimplifySuperClasses inst_loc [] dicts
-               -- Use tcSimplifySuperClasses to avoid creating loops, for the
-               -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
-          ; return (map instToId dicts, idHsWrapper, sc_binds) }
-
-    make_wrapper inst_loc tvs theta Nothing    -- Case (b)
-      = do { dicts <- newDictBndrs inst_loc theta
-          ; let dict_ids = map instToId dicts
-          ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) }
-
-      -----------------------
-      --       make_coercion
-      -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
-      -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
-      --       with kind (C s1 .. sm (T a1 .. ak)  :=:  C s1 .. sm <rep_ty>)
-      --       where rep_ty is the (eta-reduced) type rep of T
-      -- 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
-
-    make_coercion cls_tycon cls_inst_tys
-       | Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys
-       , (tycon, tc_args) <- tcSplitTyConApp last_ty   -- Should not fail
-       , Just co_con <- newTyConCo_maybe tycon
-       , let co = mkSymCoercion (mkTyConApp co_con tc_args)
-        = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
-        | otherwise    -- The newtype is transparent; no need for a cast
-        = idHsWrapper
-
-      -----------------------
-      --       make_body
-      -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs
-      -- (a) no superclasses; then we can just use the coerced dict
-      -- (b) one or more superclasses; then new need to do the unpack/repack
-       
-    make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
-       | null sc_dict_ids              -- 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
-         pat_ty       = mkTyConApp cls_tycon cls_inst_tys
-          cls_data_con = head (tyConDataCons cls_tycon)
-          cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys 
-          op_tys       = dropList sc_dict_ids cls_arg_tys
-
-------------------------
--- Ordinary instances
-
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
-  = let 
-       dfun_id    = instanceDFunId ispec
-       rigid_info = InstSkol
-       inst_ty    = idType dfun_id
-    in
-        -- Prime error recovery
-    recoverM (returnM emptyLHsBinds)           $
-    setSrcSpan (srcLocSpan (getSrcLoc dfun_id))        $
-    addErrCtxt (instDeclCtxt2 (idType dfun_id))        $
-
-       -- Instantiate the instance decl with skolem constants 
-    tcSkolSigType rigid_info inst_ty   `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
-               -- 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!
-    let
-       (clas, inst_tys') = tcSplitDFunHead inst_head'
-        (class_tyvars, sc_theta, _, op_items) = classBigSig clas
-
-        -- Instantiate the super-class context with inst_tys
-       sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
-       origin    = SigOrigin rigid_info
-    in
-        -- Create dictionary Ids from the specified instance contexts.
-    getInstLoc InstScOrigin                            `thenM` \ sc_loc -> 
-    newDictBndrs sc_loc sc_theta'                      `thenM` \ sc_dicts ->
-    getInstLoc origin                                  `thenM` \ inst_loc -> 
-    newDictBndrs inst_loc dfun_theta'                  `thenM` \ dfun_arg_dicts ->
-    newDictBndr inst_loc (mkClassPred clas inst_tys')   `thenM` \ this_dict ->
-               -- Default-method Ids may be mentioned in synthesised RHSs,
-               -- but they'll already be in the environment.
-
-       -- Typecheck the methods
-    let                -- These insts are in scope; quite a few, eh?
-       avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts
-    in
-    tcMethods origin clas inst_tyvars' 
-             dfun_theta' inst_tys' avail_insts 
-             op_items monobinds uprags         `thenM` \ (meth_ids, meth_binds) ->
-
-       -- Figure out bindings for the superclass context
-       -- Don't include this_dict in the 'givens', else
-       -- sc_dicts get bound by just selecting  from this_dict!!
-    addErrCtxt superClassCtxt
-       (tcSimplifySuperClasses inst_loc
-                        dfun_arg_dicts sc_dicts)       `thenM` \ sc_binds ->
-
-       -- It's possible that the superclass stuff might unified one
-       -- of the inst_tyavars' with something in the envt
-    checkSigTyVars inst_tyvars'        `thenM_`
-
-       -- Deal with 'SPECIALISE instance' pragmas 
-    tcPrags dfun_id (filter isSpecInstLSig uprags)     `thenM` \ prags -> 
-    
-       -- Create the result bindings
-    let
-        dict_constr   = classDataCon clas
-       scs_and_meths = map instToId sc_dicts ++ meth_ids
-       this_dict_id  = instToId this_dict
-       inline_prag | null dfun_arg_dicts = []
-                   | otherwise = [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' (map HsVar scs_and_meths)
-               -- 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)
-       all_binds  = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
-
-       main_bind = noLoc $ AbsBinds
-                           inst_tyvars'
-                           (map instToId dfun_arg_dicts)
-                           [(inst_tyvars', dfun_id, this_dict_id, 
-                                           inline_prag ++ prags)] 
-                           all_binds
-    in
-    showLIE (text "instance")          `thenM_`
-    returnM (unitBag main_bind)
-
-
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' 
-         avail_insts op_items monobinds uprags
-  =    -- Check that all the method bindings come from this class
-    let
-       sel_names = [idName sel_id | (sel_id, _) <- op_items]
-       bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
-    in
-    mappM (addErrTc . badMethodErr clas) bad_bndrs     `thenM_`
-
-       -- Make the method bindings
-    let
-       mk_method_bind = mkMethodBind origin clas inst_tys' monobinds
-    in
-    mapAndUnzipM mk_method_bind op_items       `thenM` \ (meth_insts, meth_infos) ->
-
-       -- And type check them
-       -- It's really worth making meth_insts available to the tcMethodBind
-       -- Consider     instance Monad (ST s) where
-       --                {-# INLINE (>>) #-}
-       --                (>>) = ...(>>=)...
-       -- If we don't include meth_insts, we end up with bindings like this:
-       --      rec { dict = MkD then bind ...
-       --            then = inline_me (... (GHC.Base.>>= dict) ...)
-       --            bind = ... }
-       -- The trouble is that (a) 'then' and 'dict' are mutually recursive, 
-       -- and (b) the inline_me prevents us inlining the >>= selector, which
-       -- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
-       -- is not inlined across modules. Rather ironic since this does not
-       -- happen without the INLINE pragma!  
-       --
-       -- Solution: make meth_insts available, so that 'then' refers directly
-       --           to the local 'bind' rather than going via the dictionary.
-       --
-       -- BUT WATCH OUT!  If the method type mentions the class variable, then
-       -- this optimisation is not right.  Consider
-       --      class C a where
-       --        op :: Eq a => a
-       --
-       --      instance C Int where
-       --        op = op
-       -- The occurrence of 'op' on the rhs gives rise to a constraint
-       --      op at Int
-       -- The trouble is that the 'meth_inst' for op, which is 'available', also
-       -- looks like 'op at Int'.  But they are not the same.
-    let
-       prag_fn        = mkPragFun uprags
-       all_insts      = avail_insts ++ catMaybes meth_insts
-       sig_fn n       = Just []        -- No scoped type variables, but every method has
-                                       -- a type signature, in effect, so that we check
-                                       -- the method has the right type
-       tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn
-       meth_ids       = [meth_id | (_,meth_id,_) <- meth_infos]
-    in
-
-    mapM tc_method_bind meth_infos             `thenM` \ meth_binds_s ->
+Note [Export helper functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange to export the "helper functions" of an instance declaration,
+so that they are not subject to preInlineUnconditionally, even if their
+RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
+the dict fun as Ids, not as CoreExprs, so we can't substitute a 
+non-variable for them.
+
+We could change this by making DFunUnfoldings have CoreExprs, but it
+seems a bit simpler this way.
+
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+
+   class Baz v x where
+      foo :: x -> x
+      foo y = <blah>
+
+   instance Baz Int Int
+
+From the class decl we get
+
+   $dmfoo :: forall v x. Baz v x => x -> x
+   $dmfoo y = <blah>
+
+Notice that the type is ambiguous.  That's fine, though. The instance
+decl generates
+
+   $dBazIntInt = MkBaz fooIntInt
+   fooIntInt = $dmfoo Int Int $dBazIntInt
+
+BUT this does mean we must generate the dictionary translation of
+fooIntInt directly, rather than generating source-code and
+type-checking it.  That was the bug in Trac #1061. In any case it's
+less work to generate the translated version!
+
+Note [INLINE and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Default methods need special case.  They are supposed to behave rather like
+macros.  For exmample
+
+  class Foo a where
+    op1, op2 :: Bool -> a -> a
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+  instance Foo Int where
+    -- op1 via default method
+    op2 b x = <blah>
    
-    returnM (meth_ids, unionManyBags meth_binds_s)
-\end{code}
+The instance declaration should behave
+
+   just as if 'op1' had been defined with the
+   code, and INLINE pragma, from its original
+   definition. 
+
+That is, just as if you'd written
+
+  instance Foo Int where
+    op2 b x = <blah>
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+So for the above example we generate:
+
+
+  {-# INLINE $dmop1 #-}
+  -- $dmop1 has an InlineCompulsory unfolding
+  $dmop1 d b x = op2 d (not b) x
+
+  $fFooInt = MkD $cop1 $cop2
+
+  {-# INLINE $cop1 #-}
+  $cop1 = $dmop1 $fFooInt
 
+  $cop2 = <blah>
 
-               ------------------------------
-       [Inline dfuns] Inlining 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 doesn't GHC inline $fEq?  Because it looks 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.
+Note carefullly:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+  instance $cop1.  Otherwise we'll just inline the former in the
+  latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an 
+  unfolding with an InlineCompulsory source. That means
+  that it'll be inlined at every use site, notably in
+  each instance declaration, such as $cop1.  This inlining
+  must happen even though 
+    a) $dmop1 is not saturated in $cop1
+    b) $cop1 itself has an INLINE pragma
+
+  It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+  recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+  (which makes the Unfoldings), we use the IsDefaultMethod constructor
+  in TcSpecPrags.
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Error messages}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-instDeclCtxt1 hs_inst_ty 
+instDeclCtxt1 :: LHsType Name -> SDoc
+instDeclCtxt1 hs_inst_ty
   = inst_decl_ctxt (case unLoc hs_inst_ty of
-                       HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
-                       HsPredTy pred                    -> ppr pred
-                       other                            -> ppr hs_inst_ty)     -- Don't expect this
+                        HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
+                        HsPredTy pred                    -> ppr pred
+                        _                                -> ppr hs_inst_ty)     -- Don't expect this
+instDeclCtxt2 :: Type -> SDoc
 instDeclCtxt2 dfun_ty
   = inst_decl_ctxt (ppr (mkClassPred cls tys))
   where
     (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 
-inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc
-
-superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
 
-atInstCtxt name = ptext SLIT("In the associated type instance for") <+> 
-                 quotes (ppr name)
+atInstCtxt :: Name -> SDoc
+atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
+                  quotes (ppr name)
 
-mustBeVarArgErr ty = 
-  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
+mustBeVarArgErr :: Type -> SDoc
+mustBeVarArgErr ty =
+  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
       ]
 
+wrongATArgErr :: Type -> Type -> SDoc
 wrongATArgErr ty instTy =
-  sep [ ptext SLIT("Type indexes must match class instance head")
-      , ptext SLIT("Found") <+> ppr ty <+> ptext SLIT("but expected") <+>
-         ppr instTy
+  sep [ ptext (sLit "Type indexes must match class instance head")
+      , ptext (sLit "Found") <+> quotes (ppr ty)
+        <+> ptext (sLit "but expected") <+> quotes (ppr instTy)
       ]
+
+tooManyParmsErr :: Located Name -> SDoc
+tooManyParmsErr tc_name
+  = ptext (sLit "Family instance has too many parameters:") <+> 
+    quotes (ppr tc_name)
+
+tooFewParmsErr :: Arity -> SDoc
+tooFewParmsErr arity
+  = ptext (sLit "Family instance has too few parameters; expected") <+> 
+    ppr arity
+
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr exp_arity
+  = ptext (sLit "Number of parameters must match family declaration; expected")
+    <+> ppr exp_arity
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+  = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+  = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+         , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+  
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+  = ptext (sLit "Wrong category of family instance; declaration was for a")
+    <+> kindOfFamily
+  where
+    kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
+                | isAlgTyCon family = ptext (sLit "data type")
+                | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
 \end{code}