projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Several fixes to 'deriving' including Trac #2378
[ghc-hetmet.git] / compiler / typecheck / TcDeriv.lhs
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index d414c6f..7a2954a 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -46,6 +46,7 @@ import SrcLoc
 import Util
 import ListSetOps
 import Outputable
 import Util
 import ListSetOps
 import Outputable
+import FastString
 import Bag
 \end{code}
 
 import Bag
 \end{code}
 
@@ -86,8 +87,13 @@ data DerivSpec  = DS { ds_loc     :: SrcSpan
 
 type EarlyDerivSpec = Either DerivSpec DerivSpec
        -- Left  ds => the context for the instance should be inferred
 
 type EarlyDerivSpec = Either DerivSpec DerivSpec
        -- Left  ds => the context for the instance should be inferred
-       --              (ds_theta is required)
-       -- Right ds => the context for the instance is supplied by the programmer
+       --             In this case ds_theta is the list of all the 
+       --                constraints needed, such as (Eq [a], Eq a)
+       --                The inference process is to reduce this to a 
+       --                simpler form (e.g. Eq a)
+       -- 
+       -- Right ds => the exact context for the instance is supplied 
+       --             by the programmer; it is ds_theta
 
 pprDerivSpec :: DerivSpec -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 
 
 pprDerivSpec :: DerivSpec -> SDoc
 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 
@@ -222,6 +228,9 @@ And then translate it to:
        
 Note [Newtype deriving superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        
 Note [Newtype deriving superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(See also Trac #1220 for an interesting exchange on newtype
+deriving and superclasses.)
+
 The 'tys' here come from the partial application in the deriving
 clause. The last arg is the new instance type.
 
 The 'tys' here come from the partial application in the deriving
 clause. The last arg is the new instance type.
 
@@ -253,79 +262,106 @@ when the dict is constructed in TcInstDcls.tcInstDecl2
 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
-           -> TcM ([InstInfo],         -- The generated "instance decls"
+           -> TcM ([InstInfo Name],    -- The generated "instance decls"
                    HsValBinds Name)    -- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls
                    HsValBinds Name)    -- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (returnM ([], emptyValBindsOut)) $
+  = recoverM (return ([], emptyValBindsOut)) $
     do {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
        ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
 
        ; overlap_flag <- getOverlapFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
     do {       -- Fish the "deriving"-related information out of the TcEnv
                -- And make the necessary "equations".
        ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
 
        ; overlap_flag <- getOverlapFlag
        ; let (infer_specs, given_specs) = splitEithers early_specs
-       ; (insts1, aux_binds1) <- mapAndUnzipM (genInst overlap_flag) given_specs
+       ; insts1 <- mapM (genInst overlap_flag) given_specs
 
 
-       ; final_specs <- extendLocalInstEnv (map iSpec insts1) $
+       ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
                         inferInstanceContexts overlap_flag infer_specs
 
                         inferInstanceContexts overlap_flag infer_specs
 
-       ; (insts2, aux_binds2) <- mapAndUnzipM (genInst overlap_flag) final_specs
+       ; insts2 <- mapM (genInst overlap_flag) final_specs
 
        ; is_boot <- tcIsHsBoot
 
        ; is_boot <- tcIsHsBoot
-       ; rn_binds <- makeAuxBinds is_boot tycl_decls
-                                  (concat aux_binds1 ++ concat aux_binds2)
-
-       ; let inst_info = insts1 ++ insts2
+                -- Generate the generic to/from functions from each type declaration
+       ; gen_binds <- mkGenericBinds is_boot
+       ; (inst_info, rn_binds) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 
        ; dflags <- getDOpts
 
        ; dflags <- getDOpts
-       ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" 
-                  (ddump_deriving inst_info rn_binds))
+       ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                (ddump_deriving inst_info rn_binds))
 
        ; return (inst_info, rn_binds) }
   where
 
        ; return (inst_info, rn_binds) }
   where
-    ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc
+    ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
     ddump_deriving inst_infos extra_binds
       = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
 
     ddump_deriving inst_infos extra_binds
       = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
 
-makeAuxBinds :: Bool -> [LTyClDecl Name] -> DerivAuxBinds -> TcM (HsValBinds Name)
-makeAuxBinds is_boot tycl_decls deriv_aux_binds
-  | is_boot    -- If we are compiling a hs-boot file, 
-               -- don't generate any derived bindings
-  = return emptyValBindsOut
+renameDeriv :: Bool -> LHsBinds RdrName
+           -> [(InstInfo RdrName, DerivAuxBinds)]
+           -> TcM ([InstInfo Name], HsValBinds Name)
+renameDeriv is_boot gen_binds insts
+  | is_boot    -- If we are compiling a hs-boot file, don't generate any derived bindings
+               -- The inst-info bindings will all be empty, but it's easier to
+               -- just use rn_inst_info to change the type appropriately
+  = do { rn_inst_infos <- mapM rn_inst_info inst_infos 
+       ; return (rn_inst_infos, emptyValBindsOut) }
 
   | otherwise
 
   | otherwise
-  = do { let aux_binds = listToBag (map genAuxBind (rm_dups [] deriv_aux_binds))
-               -- Generate any extra not-one-inst-decl-specific binds, 
+  = discardWarnings $   -- Discard warnings about unused bindings etc
+    do { (rn_gen, dus_gen) <- setOptM Opt_PatternSignatures $  -- Type signatures in patterns 
+                                                               -- are used in the generic binds
+                              rnTopBinds (ValBindsIn gen_binds [])
+       ; keepAliveSetTc (duDefs dus_gen)       -- Mark these guys to be kept alive
+
+               -- Generate and rename any extra not-one-inst-decl-specific binds, 
                -- notably "con2tag" and/or "tag2con" functions.  
                -- notably "con2tag" and/or "tag2con" functions.  
+               -- Bring those names into scope before renaming the instances themselves
+       ; loc <- getSrcSpanM    -- Generic loc for shared bindings
+       ; let aux_binds = listToBag $ map (genAuxBind loc) $ 
+                         rm_dups [] $ concat deriv_aux_binds
+       ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv (ValBindsIn aux_binds [])
+       ; let aux_names =  map unLoc (collectHsValBinders rn_aux_lhs)
+
+       ; bindLocalNames aux_names $ 
+    do { (rn_aux, _dus) <- rnTopBindsRHS aux_names rn_aux_lhs
+       ; rn_inst_infos <- mapM rn_inst_info inst_infos
+       ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen) } }
 
 
-       -- Generate the generic to/from functions from each type declaration
-       ; gen_binds <- mkGenericBinds tycl_decls
-
-       -- Rename these extra bindings, discarding warnings about unused bindings etc
-       -- Type signatures in patterns are used in the generic binds
-       ; discardWarnings $
-          setOptM Opt_PatternSignatures $
-          do   { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn aux_binds [])
-               ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
-               ; keepAliveSetTc (duDefs dus_gen)       -- Mark these guys to
-                                                       -- be kept alive
-               ; return (rn_deriv `plusHsValBinds` rn_gen) } }
   where
   where
+    (inst_infos, deriv_aux_binds) = unzip insts
+    
        -- Remove duplicate requests for auxilliary bindings
     rm_dups acc [] = acc
     rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
                       | otherwise            = rm_dups (b:acc) bs
 
        -- Remove duplicate requests for auxilliary bindings
     rm_dups acc [] = acc
     rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
                       | otherwise            = rm_dups (b:acc) bs
 
+
+    rn_inst_info (InstInfo { iSpec = inst, iBinds = NewTypeDerived })
+       = return (InstInfo { iSpec = inst, iBinds = NewTypeDerived })
+
+    rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs })
+       =       -- Bring the right type variables into 
+               -- scope (yuk), and rename the method binds
+          ASSERT( null sigs )
+          bindLocalNames (map Var.varName tyvars) $
+          do { (rn_binds, _fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+             ; return (InstInfo { iSpec = inst, iBinds = VanillaInst rn_binds [] }) }
+       where
+         (tyvars,_,clas,_) = instanceHead inst
+         clas_nm           = className clas
+
 -----------------------------------------
 -----------------------------------------
-mkGenericBinds :: [LTyClDecl Name] -> TcM (LHsBinds RdrName)
-mkGenericBinds tycl_decls
-  = do { tcs <- mapM tcLookupTyCon 
-                       [ tc_name | 
-                         L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls]
-               -- We are only interested in the data type declarations
+mkGenericBinds :: Bool -> TcM (LHsBinds RdrName)
+mkGenericBinds is_boot
+  | is_boot 
+  = return emptyBag
+  | otherwise
+  = do { gbl_env <- getGblEnv
+       ; let tcs = typeEnvTyCons (tcg_type_env gbl_env)
        ; return (unionManyBags [ mkTyConGenericBinds tc | 
                                  tc <- tcs, tyConHasGenerics tc ]) }
        ; return (unionManyBags [ mkTyConGenericBinds tc | 
                                  tc <- tcs, tyConHasGenerics tc ]) }
-               -- And then only in the ones whose 'has-generics' flag is on
+               -- We are only interested in the data type declarations,
+               -- and then only in the ones whose 'has-generics' flag is on
+               -- The predicate tyConHasGenerics finds both of these
 \end{code}
 
 
 \end{code}
 
 
@@ -357,12 +393,12 @@ makeDerivSpecs :: [LTyClDecl Name]
               -> TcM [EarlyDerivSpec]
 
 makeDerivSpecs tycl_decls inst_decls deriv_decls
               -> TcM [EarlyDerivSpec]
 
 makeDerivSpecs tycl_decls inst_decls deriv_decls
-  = do { eqns1 <- mapM deriveTyData $
+  = do { eqns1 <- mapAndRecoverM deriveTyData $
                      extractTyDataPreds tycl_decls ++
                     [ pd                        -- traverse assoc data families
                      | L _ (InstDecl _ _ _ ats) <- inst_decls
                     , pd <- extractTyDataPreds ats ]
                      extractTyDataPreds tycl_decls ++
                     [ pd                        -- traverse assoc data families
                      | L _ (InstDecl _ _ _ ats) <- inst_decls
                     , pd <- extractTyDataPreds ats ]
-       ; eqns2 <- mapM deriveStandalone deriv_decls
+       ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
        ; return (catMaybes (eqns1 ++ eqns2)) }
   where
     extractTyDataPreds decls =                    
        ; return (catMaybes (eqns1 ++ eqns2)) }
   where
     extractTyDataPreds decls =                    
@@ -384,9 +420,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
               <+> text "theta:" <+> ppr theta
               <+> text "tau:" <+> ppr tau)
        ; (cls, inst_tys) <- checkValidInstHead tau
               <+> text "theta:" <+> ppr theta
               <+> text "tau:" <+> ppr tau)
        ; (cls, inst_tys) <- checkValidInstHead tau
+       ; checkValidInstance tvs theta cls inst_tys
+               -- C.f. TcInstDcls.tcLocalInstDecl1
+
        ; let cls_tys = take (length inst_tys - 1) inst_tys
              inst_ty = last inst_tys
        ; let cls_tys = take (length inst_tys - 1) inst_tys
              inst_ty = last inst_tys
-
        ; traceTc (text "standalone deriving;"
               <+> text "class:" <+> ppr cls
               <+> text "class types:" <+> ppr cls_tys
        ; traceTc (text "standalone deriving;"
               <+> text "class:" <+> ppr cls
               <+> text "class types:" <+> ppr cls_tys
@@ -396,11 +434,11 @@ deriveStandalone (L loc (DerivDecl deriv_ty))
 
 ------------------------------------------------------------------
 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)
 
 ------------------------------------------------------------------
 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)
-deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name, 
-                                              tcdTyVars = tv_names, 
-                                              tcdTyPats = ty_pats }))
-  = setSrcSpan loc                   $
-    tcAddDeclCtxt decl              $
+deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, 
+                                                  tcdTyVars = tv_names, 
+                                                  tcdTyPats = ty_pats }))
+  = setSrcSpan loc     $       -- Use the location of the 'deriving' item
+    tcAddDeclCtxt decl $
     do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
              hs_app     = nlHsTyConApp tycon_name hs_ty_args
                -- We get kinding info for the tyvars by typechecking (T a b)
     do { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
              hs_app     = nlHsTyConApp tycon_name hs_ty_args
                -- We get kinding info for the tyvars by typechecking (T a b)
@@ -418,44 +456,67 @@ deriveTyData _other
 
 ------------------------------------------------------------------
 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
 
 ------------------------------------------------------------------
 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
-          -> Maybe ThetaType           -- Just    => context supplied
-                                       -- Nothing => context inferred
+          -> Maybe ThetaType   -- Just    => context supplied (standalone deriving)
+                               -- Nothing => context inferred (deriving on data decl)
           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
           -> TcRn (Maybe EarlyDerivSpec)
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
-  = do {       -- Make tc_app saturated, because that's what the
-               -- mkDataTypeEqn things expect
-               -- It might not be saturated in the standalone deriving case
-               --      derive instance Monad (T a)
-         let extra_tvs = dropList tc_args (tyConTyVars tycon)
-             full_tc_args = tc_args ++ mkTyVarTys extra_tvs
-             full_tvs = tvs ++ extra_tvs
-               
-       ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
+  , isAlgTyCon tycon   -- Check for functions, primitive types etc
+  = do { (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
+                 -- Be careful to test rep_tc here: in the case of families, 
+                 -- we want to check the instance tycon, not the family tycon
+
+       -- For standalone deriving (mtheta /= Nothing), 
+       -- check that all the data constructors are in scope
+       -- By this time we know that the thing is algebraic
+       --      because we've called checkInstHead in derivingStandalone
+       ; rdr_env <- getGlobalRdrEnv
+       ; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc)
+             not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
+       ; checkTc (isNothing mtheta || not hidden_data_cons) 
+                 (derivingHiddenErr tycon)
 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 
 
        ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
        ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 
-          -- Be careful to test rep_tc here: in the case of families, we want
-          -- to check the instance tycon, not the family tycon
        ; if isDataTyCon rep_tc then
        ; if isDataTyCon rep_tc then
-               mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys 
-                             tycon full_tc_args rep_tc rep_tc_args mtheta
+               mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys 
+                             tycon tc_args rep_tc rep_tc_args mtheta
          else
                mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
          else
                mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
-                            full_tvs cls cls_tys 
-                            tycon full_tc_args rep_tc rep_tc_args mtheta }
+                            tvs cls cls_tys 
+                            tycon tc_args rep_tc rep_tc_args mtheta }
   | otherwise
   = baleOut (derivingThingErr cls cls_tys tc_app
   | otherwise
   = baleOut (derivingThingErr cls cls_tys tc_app
-               (ptext SLIT("Last argument of the instance must be a type application")))
+           (ptext (sLit "The last argument of the instance must be a data or newtype application")))
 
 baleOut :: Message -> TcM (Maybe a)
 baleOut err = do { addErrTc err;  return Nothing }
 \end{code}
 
 
 baleOut :: Message -> TcM (Maybe a)
 baleOut err = do { addErrTc err;  return Nothing }
 \end{code}
 
-Auxiliary lookup wrapper which requires that looked up family instances are
-not type instances.  If called with a vanilla tycon, the old type application
-is simply returned.
+Note [Looking up family instances for deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcLookupFamInstExact is an auxiliary lookup wrapper which requires
+that looked-up family instances exist.  If called with a vanilla
+tycon, the old type application is simply returned.
+
+If we have
+  data instance F () = ... deriving Eq
+  data instance F () = ... deriving Eq
+then tcLookupFamInstExact will be confused by the two matches;
+but that can't happen because tcInstDecls1 doesn't call tcDeriving
+if there are any overlaps.
+
+There are two other things that might go wrong with the lookup.
+First, we might see a standalone deriving clause
+       deriving Eq (F ())
+when there is no data instance F () in scope. 
+
+Note that it's OK to have
+  data instance F [a] = ...
+  deriving Eq (F [(a,b)])
+where the match is not exact; the same holds for ordinary data types
+with standalone deriving declrations.
 
 \begin{code}
 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
 
 \begin{code}
 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
@@ -465,18 +526,14 @@ tcLookupFamInstExact tycon tys
   | otherwise
   = do { maybeFamInst <- tcLookupFamInst tycon tys
        ; case maybeFamInst of
   | otherwise
   = do { maybeFamInst <- tcLookupFamInst tycon tys
        ; case maybeFamInst of
-           Nothing                     -> famInstNotFound tycon tys False
-           Just famInst@(_, rep_tys)
-             | not variable_only_subst -> famInstNotFound tycon tys True
-             | otherwise               -> return famInst
-             where
-               tvs                 = map (Type.getTyVar 
-                                             "TcDeriv.tcLookupFamInstExact") 
-                                         rep_tys
-              variable_only_subst  = all Type.isTyVarTy rep_tys &&
-                                     sizeVarSet (mkVarSet tvs) == length tvs
-                                       -- renaming may have no repetitions
+           Nothing      -> famInstNotFound tycon tys
+           Just famInst -> return famInst
        }
        }
+
+famInstNotFound :: TyCon -> [Type] -> TcM a
+famInstNotFound tycon tys 
+  = failWithTc (ptext (sLit "No family instance for")
+                       <+> quotes (pprTypeApp tycon (ppr tycon) tys))
 \end{code}
 
 
 \end{code}
 
 
@@ -501,27 +558,13 @@ mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
   = ASSERT( null cls_tys )
     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
   = ASSERT( null cls_tys )
     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
-mk_data_eqn :: InstOrigin -> [TyVar] -> Class 
-            -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
-            -> TcM (Maybe EarlyDerivSpec)
+mk_data_eqn, mk_typeable_eqn
+   :: InstOrigin -> [TyVar] -> Class 
+   -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
+   -> TcM (Maybe EarlyDerivSpec)
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
-  | cls `hasKey` typeableClassKey
-  =    -- The Typeable class is special in several ways
-       --        data T a b = ... deriving( Typeable )
-       -- gives
-       --        instance Typeable2 T where ...
-       -- Notice that:
-       -- 1. There are no constraints in the instance
-       -- 2. There are no type variables either
-       -- 3. The actual class we want to generate isn't necessarily
-       --      Typeable; it depends on the arity of the type
-    do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
-       ; dfun_name <- new_dfun_name real_clas tycon
-       ; loc <- getSrcSpanM
-       ; return (Just $ Right $
-                 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
-                    , ds_cls = real_clas, ds_tys = [mkTyConApp tycon []] 
-                    , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+  | getName cls `elem` typeableClassNames
+  = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 
   | otherwise
   = do { dfun_name <- new_dfun_name cls tycon
 
   | otherwise
   = do { dfun_name <- new_dfun_name cls tycon
@@ -533,20 +576,51 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
                                dataConInstOrigArgTys data_con rep_tc_args,
                    not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
+                       -- See Note [Superclasses of derived instance]
+             sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+                                         (classSCTheta cls)
+             inst_tys =  [mkTyConApp tycon tc_args]
+
              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
              stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
              stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
-             all_constraints = stupid_constraints ++ ordinary_constraints
-                        -- see Note [Data decl contexts] above
+             all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 
 
              spec = DS { ds_loc = loc, ds_orig = orig
                        , ds_name = dfun_name, ds_tvs = tvs 
-                       , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
+                       , ds_cls = cls, ds_tys = inst_tys
                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 
                        , ds_theta =  mtheta `orElse` all_constraints
                        , ds_newtype = False }
 
        ; return (if isJust mtheta then Just (Right spec)       -- Specified context
                                   else Just (Left spec)) }     -- Infer context
 
+mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
+       -- The Typeable class is special in several ways
+       --        data T a b = ... deriving( Typeable )
+       -- gives
+       --        instance Typeable2 T where ...
+       -- Notice that:
+       -- 1. There are no constraints in the instance
+       -- 2. There are no type variables either
+       -- 3. The actual class we want to generate isn't necessarily
+       --      Typeable; it depends on the arity of the type
+  | isNothing mtheta   -- deriving on a data type decl
+  = do { checkTc (cls `hasKey` typeableClassKey)
+                 (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
+       ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
+       ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
+
+  | otherwise          -- standaone deriving
+  = do { checkTc (null tc_args)
+                 (ptext (sLit "Derived typeable instance must be of form (Typeable") 
+                       <> int (tyConArity tycon) <+> ppr tycon <> rparen)
+       ; dfun_name <- new_dfun_name cls tycon
+       ; loc <- getSrcSpanM
+       ; return (Just $ Right $
+                 DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
+                    , ds_cls = cls, ds_tys = [mkTyConApp tycon []] 
+                    , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
+
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
@@ -560,28 +634,27 @@ checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
   | notNull cls_tys    
   = Just ty_args_why   -- e.g. deriving( Foo s )
   | otherwise
   | notNull cls_tys    
   = Just ty_args_why   -- e.g. deriving( Foo s )
   | otherwise
-  = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
-       []     -> Just (non_std_why cls)
-       [cond] -> cond (mayDeriveDataTypeable, rep_tc)
-       _other -> pprPanic "checkSideConditions" (ppr cls)
+  = case sideConditions cls of
+       Just cond -> cond (mayDeriveDataTypeable, rep_tc)
+       Nothing   -> Just non_std_why
   where
   where
-    ty_args_why        = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
-
-non_std_why :: Class -> SDoc
-non_std_why cls = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
-
-sideConditions :: [(Unique, Condition)]
-sideConditions
-  = [  (eqClassKey,       cond_std),
-       (ordClassKey,      cond_std),
-       (readClassKey,     cond_std),
-       (showClassKey,     cond_std),
-       (enumClassKey,     cond_std `andCond` cond_isEnumeration),
-       (ixClassKey,       cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
-       (boundedClassKey,  cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
-       (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK),
-       (dataClassKey,     cond_mayDeriveDataTypeable `andCond` cond_std)
-    ]
+    ty_args_why        = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
+    non_std_why = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
+
+sideConditions :: Class -> Maybe Condition
+sideConditions cls
+  | cls_key == eqClassKey   = Just cond_std
+  | cls_key == ordClassKey  = Just cond_std
+  | cls_key == readClassKey = Just cond_std
+  | cls_key == showClassKey = Just cond_std
+  | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey   = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+  | cls_key == boundedClassKey = Just (cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct))
+  | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std)
+  | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
+  | otherwise = Nothing
+  where
+    cls_key = getUnique cls
 
 type Condition = (Bool, TyCon) -> Maybe SDoc
        -- Bool is whether or not we are allowed to derive Data and Typeable
 
 type Condition = (Bool, TyCon) -> Maybe SDoc
        -- Bool is whether or not we are allowed to derive Data and Typeable
@@ -595,7 +668,7 @@ orCond c1 c2 tc
        Nothing -> Nothing              -- c1 succeeds
        Just x  -> case c2 tc of        -- c1 fails
                     Nothing -> Nothing
        Nothing -> Nothing              -- c1 succeeds
        Just x  -> case c2 tc of        -- c1 fails
                     Nothing -> Nothing
-                    Just y  -> Just (x $$ ptext SLIT("  and") $$ y)
+                    Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
                                        -- Both fail
 
 andCond :: Condition -> Condition -> Condition
                                        -- Both fail
 
 andCond :: Condition -> Condition -> Condition
@@ -611,9 +684,9 @@ cond_std (_, rep_tc)
   where
     data_cons       = tyConDataCons rep_tc
     no_cons_why            = quotes (pprSourceTyCon rep_tc) <+> 
   where
     data_cons       = tyConDataCons rep_tc
     no_cons_why            = quotes (pprSourceTyCon rep_tc) <+> 
-                     ptext SLIT("has no data constructors")
+                     ptext (sLit "has no data constructors")
     existential_why = quotes (pprSourceTyCon rep_tc) <+> 
     existential_why = quotes (pprSourceTyCon rep_tc) <+> 
-                     ptext SLIT("has non-Haskell-98 constructor(s)")
+                     ptext (sLit "has non-Haskell-98 constructor(s)")
   
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
   
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
@@ -621,7 +694,7 @@ cond_isEnumeration (_, rep_tc)
   | otherwise                = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
   | otherwise                = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
-         ptext SLIT("has non-nullary constructors")
+         ptext (sLit "has non-nullary constructors")
 
 cond_isProduct :: Condition
 cond_isProduct (_, rep_tc)
 
 cond_isProduct :: Condition
 cond_isProduct (_, rep_tc)
@@ -629,7 +702,7 @@ cond_isProduct (_, rep_tc)
   | otherwise            = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
   | otherwise            = Just why
   where
     why = quotes (pprSourceTyCon rep_tc) <+> 
-         ptext SLIT("has more than one constructor")
+         ptext (sLit "has more than one constructor")
 
 cond_typeableOK :: Condition
 -- OK for Typeable class
 
 cond_typeableOK :: Condition
 -- OK for Typeable class
@@ -643,18 +716,18 @@ cond_typeableOK (_, rep_tc)
   | otherwise                  = Nothing
   where
     too_many = quotes (pprSourceTyCon rep_tc) <+> 
   | otherwise                  = Nothing
   where
     too_many = quotes (pprSourceTyCon rep_tc) <+> 
-              ptext SLIT("has too many arguments")
+              ptext (sLit "has too many arguments")
     bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
     bad_kind = quotes (pprSourceTyCon rep_tc) <+> 
-              ptext SLIT("has arguments of kind other than `*'")
+              ptext (sLit "has arguments of kind other than `*'")
     fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
     fam_inst = quotes (pprSourceTyCon rep_tc) <+> 
-              ptext SLIT("is a type family")
+              ptext (sLit "is a type family")
 
 cond_mayDeriveDataTypeable :: Condition
 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
  | mayDeriveDataTypeable = Nothing
  | otherwise = Just why
   where
 
 cond_mayDeriveDataTypeable :: Condition
 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
  | mayDeriveDataTypeable = Nothing
  | otherwise = Just why
   where
-    why  = ptext SLIT("You need -XDeriveDataTypeable to derive an instance for this class")
+    why  = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
 
 std_class_via_iso :: Class -> Bool
 std_class_via_iso clas -- These standard classes can be derived for a newtype
 
 std_class_via_iso :: Class -> Bool
 std_class_via_iso clas -- These standard classes can be derived for a newtype
@@ -666,11 +739,36 @@ std_class_via_iso clas    -- These standard classes can be derived for a newtype
 
 new_dfun_name :: Class -> TyCon -> TcM Name
 new_dfun_name clas tycon       -- Just a simple wrapper
 
 new_dfun_name :: Class -> TyCon -> TcM Name
 new_dfun_name clas tycon       -- Just a simple wrapper
-  = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
+  = do { loc <- getSrcSpanM    -- The location of the instance decl, not of the tycon
+       ; newDFunName clas [mkTyConApp tycon []] loc }
        -- The type passed to newDFunName is only used to generate
        -- a suitable string; hence the empty type arg list
 \end{code}
 
        -- The type passed to newDFunName is only used to generate
        -- a suitable string; hence the empty type arg list
 \end{code}
 
+Note [Superclasses of derived instance] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+       data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is 
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint 
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+       data T a = MkT deriving( Data, Typeable )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+       instance Typable a => Data (T a) where ...
+
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *
@@ -707,7 +805,7 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
        mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
        std_err = derivingThingErr cls cls_tys tc_app $
                  vcat [fromJust mb_std_err,
        mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
        std_err = derivingThingErr cls cls_tys tc_app $
                  vcat [fromJust mb_std_err,
-                       ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
+                       ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
 
        -- Here is the plan for newtype derivings.  We see
        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
 
        -- Here is the plan for newtype derivings.  We see
        --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
@@ -747,10 +845,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
 
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
 
-       -- Note [newtype representation]
-       -- Need newTyConRhs *not* newTyConRep to get the representation 
-       -- type, because the latter looks through all intermediate newtypes
-       -- For example
+       -- Note [Newtype representation]
+       -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       -- Need newTyConRhs (*not* a recursive representation finder) 
+       -- to get the representation type. For example
        --      newtype B = MkB Int
        --      newtype A = MkA B deriving( Num )
        -- We want the Num instance of B, *not* the Num instance of Int,
        --      newtype B = MkB Int
        --      newtype A = MkA B deriving( Num )
        -- We want the Num instance of B, *not* the Num instance of Int,
@@ -798,9 +896,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
        right_arity = length cls_tys + 1 == classArity cls
 
                -- Never derive Read,Show,Typeable,Data this way 
        right_arity = length cls_tys + 1 == classArity cls
 
                -- Never derive Read,Show,Typeable,Data this way 
-       non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
+       non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
+                                                 typeableClassNames)
        can_derive_via_isomorphism
        can_derive_via_isomorphism
-          =  not (getUnique cls `elem` non_iso_classes)
+          =  not (non_iso_class cls)
           && right_arity                       -- Well kinded;
                                                -- eg not: newtype T ... deriving( ST )
                                                --      because ST needs *2* type params
           && right_arity                       -- Well kinded;
                                                -- eg not: newtype T ... deriving( ST )
                                                --      because ST needs *2* type params
@@ -841,19 +940,19 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
                --      arguments must be type variables (not more complex indexes)
 
        cant_derive_err = derivingThingErr cls cls_tys tc_app
                --      arguments must be type variables (not more complex indexes)
 
        cant_derive_err = derivingThingErr cls cls_tys tc_app
-                               (vcat [ptext SLIT("even with cunning newtype deriving:"),
+                               (vcat [ptext (sLit "even with cunning newtype deriving:"),
                                        if isRecursiveTyCon tycon then
                                        if isRecursiveTyCon tycon then
-                                         ptext SLIT("the newtype may be recursive")
+                                         ptext (sLit "the newtype may be recursive")
                                        else empty,
                                        if not right_arity then 
                                        else empty,
                                        if not right_arity then 
-                                         quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1")
+                                         quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
                                        else empty,
                                        if not (n_tyargs_to_keep >= 0) then 
                                        else empty,
                                        if not (n_tyargs_to_keep >= 0) then 
-                                         ptext SLIT("the type constructor has wrong kind")
+                                         ptext (sLit "the type constructor has wrong kind")
                                        else if not (n_args_to_keep >= 0) then
                                        else if not (n_args_to_keep >= 0) then
-                                         ptext SLIT("the representation type has wrong kind")
+                                         ptext (sLit "the representation type has wrong kind")
                                        else if not eta_ok then 
                                        else if not eta_ok then 
-                                         ptext SLIT("the eta-reduction property does not hold")
+                                         ptext (sLit "the eta-reduction property does not hold")
                                        else empty
                                      ])
 \end{code}
                                        else empty
                                      ])
 \end{code}
@@ -903,7 +1002,7 @@ inferInstanceContexts oflag infer_specs
     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
     iterate_deriv n current_solns
       | n > 20         -- Looks as if we are in an infinite loop
     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
     iterate_deriv n current_solns
       | n > 20         -- Looks as if we are in an infinite loop
-               -- This can happen if we have -fallow-undecidable-instances
+               -- This can happen if we have -XUndecidableInstances
                -- (See TcSimplify.tcSimplifyDeriv.)
       = pprPanic "solveDerivEqns: probable loop" 
                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
                -- (See TcSimplify.tcSimplifyDeriv.)
       = pprPanic "solveDerivEqns: probable loop" 
                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
@@ -1041,50 +1140,41 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo, DerivAuxBinds)
+genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
 genInst oflag spec
   | ds_newtype spec
   = return (InstInfo { iSpec = mkInstance1 oflag spec 
                     , iBinds = NewTypeDerived }, [])
 
   | otherwise
 genInst oflag spec
   | ds_newtype spec
   = return (InstInfo { iSpec = mkInstance1 oflag spec 
                     , iBinds = NewTypeDerived }, [])
 
   | otherwise
-  = do { fix_env <- getFixityEnv
-       ; let
-           inst                    = mkInstance1 oflag spec
-           (tyvars,_,clas,[ty])    = instanceHead inst
-           clas_nm                 = className clas
-           (visible_tycon, tyArgs) = tcSplitTyConApp ty 
+  = do { let loc                     = getSrcSpan (ds_name spec)
+             inst                    = mkInstance1 oflag spec
+             (_,_,clas,[ty])         = instanceHead inst
+             (visible_tycon, tyArgs) = tcSplitTyConApp ty 
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
         ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
 
           -- In case of a family instance, we need to use the representation
           -- tycon (after all, it has the data constructors)
         ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
-       ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
-
-       -- Bring the right type variables into 
-       -- scope, and rename the method binds
-       -- It's a bit yukky that we return *renamed* InstInfo, but
-       -- *non-renamed* auxiliary bindings
-       ; (rn_meth_binds, _fvs) <- discardWarnings $ 
-                                  bindLocalNames (map Var.varName tyvars) $
-                                  rnMethodBinds clas_nm (\_ -> []) [] meth_binds
+       ; fix_env <- getFixityEnv
+       ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas tycon
 
        -- Build the InstInfo
        ; return (InstInfo { iSpec = inst, 
 
        -- Build the InstInfo
        ; return (InstInfo { iSpec = inst, 
-                            iBinds = VanillaInst rn_meth_binds [] },
+                            iBinds = VanillaInst meth_binds [] },
                  aux_binds)
         }
 
                  aux_binds)
         }
 
-genDerivBinds :: Class -> FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
-genDerivBinds clas fix_env tycon
+genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+genDerivBinds loc fix_env clas tycon
   | className clas `elem` typeableClassNames
   | className clas `elem` typeableClassNames
-  = (gen_Typeable_binds tycon, [])
+  = (gen_Typeable_binds loc tycon, [])
 
   | otherwise
   = case assocMaybe gen_list (getUnique clas) of
 
   | otherwise
   = case assocMaybe gen_list (getUnique clas) of
-       Just gen_fn -> gen_fn tycon
+       Just gen_fn -> gen_fn loc tycon
        Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
   where
        Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
   where
-    gen_list :: [(Unique, TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
+    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
     gen_list = [(eqClassKey,       gen_Eq_binds)
               ,(ordClassKey,      gen_Ord_binds)
               ,(enumClassKey,     gen_Enum_binds)
     gen_list = [(eqClassKey,       gen_Eq_binds)
               ,(ordClassKey,      gen_Ord_binds)
               ,(enumClassKey,     gen_Enum_binds)
@@ -1092,7 +1182,7 @@ genDerivBinds clas fix_env tycon
               ,(ixClassKey,       gen_Ix_binds)
               ,(showClassKey,     gen_Show_binds fix_env)
               ,(readClassKey,     gen_Read_binds fix_env)
               ,(ixClassKey,       gen_Ix_binds)
               ,(showClassKey,     gen_Show_binds fix_env)
               ,(readClassKey,     gen_Read_binds fix_env)
-              ,(dataClassKey,     gen_Data_binds fix_env)
+              ,(dataClassKey,     gen_Data_binds)
               ]
 \end{code}
 
               ]
 \end{code}
 
@@ -1106,30 +1196,28 @@ genDerivBinds clas fix_env tycon
 \begin{code}
 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
 derivingThingErr clas tys ty why
 \begin{code}
 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
 derivingThingErr clas tys ty why
-  = sep [hsep [ptext SLIT("Can't make a derived instance of"), 
+  = sep [hsep [ptext (sLit "Can't make a derived instance of"), 
               quotes (ppr pred)],
         nest 2 (parens why)]
   where
     pred = mkClassPred clas (tys ++ [ty])
 
               quotes (ppr pred)],
         nest 2 (parens why)]
   where
     pred = mkClassPred clas (tys ++ [ty])
 
+derivingHiddenErr :: TyCon -> SDoc
+derivingHiddenErr tc
+  = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
+       2 (ptext (sLit "so you cannot derive an instance for it"))
+
 standaloneCtxt :: LHsType Name -> SDoc
 standaloneCtxt :: LHsType Name -> SDoc
-standaloneCtxt ty = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty)
+standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 
+                      2 (quotes (ppr ty))
 
 derivInstCtxt :: Class -> [Type] -> Message
 derivInstCtxt clas inst_tys
 
 derivInstCtxt :: Class -> [Type] -> Message
 derivInstCtxt clas inst_tys
-  = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
+  = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred
 
 badDerivedPred :: PredType -> Message
 badDerivedPred pred
-  = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
-         ptext SLIT("type variables that are not data type parameters"),
-         nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
-
-famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
-famInstNotFound tycon tys notExact
-  = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
-  where
-    msg = ptext $ if notExact
-                 then SLIT("No family instance exactly matching")
-                 else SLIT("More than one family instance for")
+  = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
+         ptext (sLit "type variables that are not data type parameters"),
+         nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
 \end{code}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)