compiler/typecheck/TcDeriv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Handles @deriving@ clauses on @data@ declarations.
   7
   8 \begin{code}
   9 module TcDeriv ( tcDeriving ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn
  14 import DynFlags
  15
  16 import Generics
  17 import TcRnMonad
  18 import TcEnv
  19 import TcClassDcl( tcAddDeclCtxt )      -- Small helper
  20 import TcGenDeriv                       -- Deriv stuff
  21 import InstEnv
  22 import Inst
  23 import TcHsType
  24 import TcMType
  25 import TcSimplify
  26
  27 import RnBinds
  28 import RnEnv
  29 import HscTypes
  30
  31 import Class
  32 import Type
  33 import ErrUtils
  34 import MkId
  35 import DataCon
  36 import Maybes
  37 import RdrName
  38 import Name
  39 import NameSet
  40 import TyCon
  41 import TcType
  42 import Var
  43 import VarSet
  44 import PrelNames
  45 import SrcLoc
  46 import Util
  47 import ListSetOps
  48 import Outputable
  49 import Bag
  50 \end{code}
  51
  52 %************************************************************************
  53 %*                                                                      *
  54                 Overview
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 Overall plan
  59 ~~~~~~~~~~~~
  60 1.  Convert the decls (i.e. data/newtype deriving clauses,
  61     plus standalone deriving) to [EarlyDerivSpec]
  62
  63 2.  Infer the missing contexts for the Left DerivSpecs
  64
  65 3.  Add the derived bindings, generating InstInfos
  66
  67 \begin{code}
  68 -- DerivSpec is purely  local to this module
  69 data DerivSpec  = DS { ds_loc     :: SrcSpan
  70                      , ds_orig    :: InstOrigin
  71                      , ds_name    :: Name
  72                      , ds_tvs     :: [TyVar]
  73                      , ds_theta   :: ThetaType
  74                      , ds_cls     :: Class
  75                      , ds_tys     :: [Type]
  76                      , ds_newtype :: Bool }
  77         -- This spec implies a dfun declaration of the form
  78         --       df :: forall tvs. theta => C tys
  79         -- The Name is the name for the DFun we'll build
  80         -- The tyvars bind all the variables in the theta
  81         -- For family indexes, the tycon is the *family* tycon
  82         --              (not the representation tycon)
  83
  84         -- ds_newtype = True  <=> Newtype deriving
  85         --              False <=> Vanilla deriving
  86
  87 type EarlyDerivSpec = Either DerivSpec DerivSpec
  88         -- Left  ds => the context for the instance should be inferred
  89         --              (ds_theta is required)
  90         -- Right ds => the context for the instance is supplied by the programmer
  91
  92 pprDerivSpec :: DerivSpec -> SDoc
  93 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
  94                    ds_cls = c, ds_tys = tys, ds_theta = rhs })
  95   = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
  96             <+> equals <+> ppr rhs)
  97 \end{code}
  98
  99
 100 Inferring missing contexts
 101 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 102 Consider
 103
 104         data T a b = C1 (Foo a) (Bar b)
 105                    | C2 Int (T b a)
 106                    | C3 (T a a)
 107                    deriving (Eq)
 108
 109 [NOTE: See end of these comments for what to do with
 110         data (C a, D b) => T a b = ...
 111 ]
 112
 113 We want to come up with an instance declaration of the form
 114
 115         instance (Ping a, Pong b, ...) => Eq (T a b) where
 116                 x == y = ...
 117
 118 It is pretty easy, albeit tedious, to fill in the code "...".  The
 119 trick is to figure out what the context for the instance decl is,
 120 namely @Ping@, @Pong@ and friends.
 121
 122 Let's call the context reqd for the T instance of class C at types
 123 (a,b, ...)  C (T a b).  Thus:
 124
 125         Eq (T a b) = (Ping a, Pong b, ...)
 126
 127 Now we can get a (recursive) equation from the @data@ decl:
 128
 129         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 130                    u Eq (T b a) u Eq Int        -- From C2
 131                    u Eq (T a a)                 -- From C3
 132
 133 Foo and Bar may have explicit instances for @Eq@, in which case we can
 134 just substitute for them.  Alternatively, either or both may have
 135 their @Eq@ instances given by @deriving@ clauses, in which case they
 136 form part of the system of equations.
 137
 138 Now all we need do is simplify and solve the equations, iterating to
 139 find the least fixpoint.  Notice that the order of the arguments can
 140 switch around, as here in the recursive calls to T.
 141
 142 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 143
 144 We start with:
 145
 146         Eq (T a b) = {}         -- The empty set
 147
 148 Next iteration:
 149         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 150                    u Eq (T b a) u Eq Int        -- From C2
 151                    u Eq (T a a)                 -- From C3
 152
 153         After simplification:
 154                    = Eq a u Ping b u {} u {} u {}
 155                    = Eq a u Ping b
 156
 157 Next iteration:
 158
 159         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 160                    u Eq (T b a) u Eq Int        -- From C2
 161                    u Eq (T a a)                 -- From C3
 162
 163         After simplification:
 164                    = Eq a u Ping b
 165                    u (Eq b u Ping a)
 166                    u (Eq a u Ping a)
 167
 168                    = Eq a u Ping b u Eq b u Ping a
 169
 170 The next iteration gives the same result, so this is the fixpoint.  We
 171 need to make a canonical form of the RHS to ensure convergence.  We do
 172 this by simplifying the RHS to a form in which
 173
 174         - the classes constrain only tyvars
 175         - the list is sorted by tyvar (major key) and then class (minor key)
 176         - no duplicates, of course
 177
 178 So, here are the synonyms for the ``equation'' structures:
 179
 180
 181 Note [Data decl contexts]
 182 ~~~~~~~~~~~~~~~~~~~~~~~~~
 183 Consider
 184
 185         data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
 186
 187 We will need an instance decl like:
 188
 189         instance (Read a, RealFloat a) => Read (Complex a) where
 190           ...
 191
 192 The RealFloat in the context is because the read method for Complex is bound
 193 to construct a Complex, and doing that requires that the argument type is
 194 in RealFloat.
 195
 196 But this ain't true for Show, Eq, Ord, etc, since they don't construct
 197 a Complex; they only take them apart.
 198
 199 Our approach: identify the offending classes, and add the data type
 200 context to the instance decl.  The "offending classes" are
 201
 202         Read, Enum?
 203
 204 FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
 205 pattern matching against a constructor from a data type with a context
 206 gives rise to the constraints for that context -- or at least the thinned
 207 version.  So now all classes are "offending".
 208
 209 Note [Newtype deriving]
 210 ~~~~~~~~~~~~~~~~~~~~~~~
 211 Consider this:
 212     class C a b
 213     instance C [a] Char
 214     newtype T = T Char deriving( C [a] )
 215
 216 Notice the free 'a' in the deriving.  We have to fill this out to
 217     newtype T = T Char deriving( forall a. C [a] )
 218
 219 And then translate it to:
 220     instance C [a] Char => C [a] T where ...
 221
 222
 223 Note [Newtype deriving superclasses]
 224 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 225 The 'tys' here come from the partial application in the deriving
 226 clause. The last arg is the new instance type.
 227
 228 We must pass the superclasses; the newtype might be an instance
 229 of them in a different way than the representation type
 230 E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
 231 Then the Show instance is not done via isomorphism; it shows
 232         Foo 3 as "Foo 3"
 233 The Num instance is derived via isomorphism, but the Show superclass
 234 dictionary must the Show instance for Foo, *not* the Show dictionary
 235 gotten from the Num dictionary. So we must build a whole new dictionary
 236 not just use the Num one.  The instance we want is something like:
 237      instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
 238         (+) = ((+)@a)
 239         ...etc...
 240 There may be a coercion needed which we get from the tycon for the newtype
 241 when the dict is constructed in TcInstDcls.tcInstDecl2
 242
 243
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 \begin{code}
 253 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
 254             -> [LInstDecl Name]  -- All instance declarations
 255             -> [LDerivDecl Name] -- All stand-alone deriving declarations
 256             -> TcM ([InstInfo],         -- The generated "instance decls"
 257                     HsValBinds Name)    -- Extra generated top-level bindings
 258
 259 tcDeriving tycl_decls inst_decls deriv_decls
 260   = recoverM (returnM ([], emptyValBindsOut)) $
 261     do  {       -- Fish the "deriving"-related information out of the TcEnv
 262                 -- And make the necessary "equations".
 263         ; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
 264
 265         ; overlap_flag <- getOverlapFlag
 266         ; let (infer_specs, given_specs) = splitEithers early_specs
 267         ; (insts1, aux_binds1) <- mapAndUnzipM (genInst overlap_flag) given_specs
 268
 269         ; final_specs <- extendLocalInstEnv (map iSpec insts1) $
 270                          inferInstanceContexts overlap_flag infer_specs
 271
 272         ; (insts2, aux_binds2) <- mapAndUnzipM (genInst overlap_flag) final_specs
 273
 274         ; is_boot <- tcIsHsBoot
 275         ; rn_binds <- makeAuxBinds is_boot tycl_decls
 276                                    (concat aux_binds1 ++ concat aux_binds2)
 277
 278         ; let inst_info = insts1 ++ insts2
 279
 280         ; dflags <- getDOpts
 281         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
 282                    (ddump_deriving inst_info rn_binds))
 283
 284         ; return (inst_info, rn_binds) }
 285   where
 286     ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc
 287     ddump_deriving inst_infos extra_binds
 288       = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
 289
 290 makeAuxBinds :: Bool -> [LTyClDecl Name] -> DerivAuxBinds -> TcM (HsValBinds Name)
 291 makeAuxBinds is_boot tycl_decls deriv_aux_binds
 292   | is_boot     -- If we are compiling a hs-boot file,
 293                 -- don't generate any derived bindings
 294   = return emptyValBindsOut
 295
 296   | otherwise
 297   = do  { let aux_binds = listToBag (map genAuxBind (rm_dups [] deriv_aux_binds))
 298                 -- Generate any extra not-one-inst-decl-specific binds,
 299                 -- notably "con2tag" and/or "tag2con" functions.
 300
 301         -- Generate the generic to/from functions from each type declaration
 302         ; gen_binds <- mkGenericBinds tycl_decls
 303
 304         -- Rename these extra bindings, discarding warnings about unused bindings etc
 305         -- Type signatures in patterns are used in the generic binds
 306         ; discardWarnings $
 307           setOptM Opt_PatternSignatures $
 308           do    { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn aux_binds [])
 309                 ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds [])
 310                 ; keepAliveSetTc (duDefs dus_gen)       -- Mark these guys to
 311                                                         -- be kept alive
 312                 ; return (rn_deriv `plusHsValBinds` rn_gen) } }
 313   where
 314         -- Remove duplicate requests for auxilliary bindings
 315     rm_dups acc [] = acc
 316     rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
 317                        | otherwise            = rm_dups (b:acc) bs
 318
 319 -----------------------------------------
 320 mkGenericBinds :: [LTyClDecl Name] -> TcM (LHsBinds RdrName)
 321 mkGenericBinds tycl_decls
 322   = do  { tcs <- mapM tcLookupTyCon
 323                         [ tc_name |
 324                           L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls]
 325                 -- We are only interested in the data type declarations
 326         ; return (unionManyBags [ mkTyConGenericBinds tc |
 327                                   tc <- tcs, tyConHasGenerics tc ]) }
 328                 -- And then only in the ones whose 'has-generics' flag is on
 329 \end{code}
 330
 331
 332 %************************************************************************
 333 %*                                                                      *
 334                 From HsSyn to DerivSpec
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 @makeDerivSpecs@ fishes around to find the info about needed derived
 339 instances.  Complicating factors:
 340 \begin{itemize}
 341 \item
 342 We can only derive @Enum@ if the data type is an enumeration
 343 type (all nullary data constructors).
 344
 345 \item
 346 We can only derive @Ix@ if the data type is an enumeration {\em
 347 or} has just one data constructor (e.g., tuples).
 348 \end{itemize}
 349
 350 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 351 all those.
 352
 353 \begin{code}
 354 makeDerivSpecs :: [LTyClDecl Name]
 355                -> [LInstDecl Name]
 356                -> [LDerivDecl Name]
 357                -> TcM [EarlyDerivSpec]
 358
 359 makeDerivSpecs tycl_decls inst_decls deriv_decls
 360   = do  { eqns1 <- mapM deriveTyData $
 361                      extractTyDataPreds tycl_decls ++
 362                      [ pd                        -- traverse assoc data families
 363                      | L _ (InstDecl _ _ _ ats) <- inst_decls
 364                      , pd <- extractTyDataPreds ats ]
 365         ; eqns2 <- mapM deriveStandalone deriv_decls
 366         ; return (catMaybes (eqns1 ++ eqns2)) }
 367   where
 368     extractTyDataPreds decls =
 369       [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
 370
 371
 372 ------------------------------------------------------------------
 373 deriveStandalone :: LDerivDecl Name -> TcM (Maybe EarlyDerivSpec)
 374 -- Standalone deriving declarations
 375 --  e.g.   deriving instance show a => Show (T a)
 376 -- Rather like tcLocalInstDecl
 377 deriveStandalone (L loc (DerivDecl deriv_ty))
 378   = setSrcSpan loc                   $
 379     addErrCtxt (standaloneCtxt deriv_ty)  $
 380     do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
 381        ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
 382        ; traceTc (text "standalone deriving;"
 383               <+> text "tvs:" <+> ppr tvs
 384               <+> text "theta:" <+> ppr theta
 385               <+> text "tau:" <+> ppr tau)
 386        ; (cls, inst_tys) <- checkValidInstHead tau
 387        ; let cls_tys = take (length inst_tys - 1) inst_tys
 388              inst_ty = last inst_tys
 389
 390        ; traceTc (text "standalone deriving;"
 391               <+> text "class:" <+> ppr cls
 392               <+> text "class types:" <+> ppr cls_tys
 393               <+> text "type:" <+> ppr inst_ty)
 394        ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
 395                    (Just theta) }
 396
 397 ------------------------------------------------------------------
 398 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM (Maybe EarlyDerivSpec)
 399 deriveTyData (deriv_pred, L loc decl@(TyData { tcdLName = L _ tycon_name,
 400                                                tcdTyVars = tv_names,
 401                                                tcdTyPats = ty_pats }))
 402   = setSrcSpan loc                   $
 403     tcAddDeclCtxt decl               $
 404     do  { let hs_ty_args = ty_pats `orElse` map (nlHsTyVar . hsLTyVarName) tv_names
 405               hs_app     = nlHsTyConApp tycon_name hs_ty_args
 406                 -- We get kinding info for the tyvars by typechecking (T a b)
 407                 -- Hence forming a tycon application and then dis-assembling it
 408         ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
 409         ; tcExtendTyVarEnv tvs $        -- Deriving preds may (now) mention
 410                                         -- the type variables for the type constructor
 411     do  { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
 412                 -- The "deriv_pred" is a LHsType to take account of the fact that for
 413                 -- newtype deriving we allow deriving (forall a. C [a]).
 414         ; mkEqnHelp DerivOrigin (tvs++deriv_tvs) cls cls_tys tc_app Nothing } }
 415
 416 deriveTyData _other
 417   = panic "derivTyData" -- Caller ensures that only TyData can happen
 418
 419 ------------------------------------------------------------------
 420 mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
 421           -> Maybe ThetaType            -- Just    => context supplied
 422                                         -- Nothing => context inferred
 423           -> TcRn (Maybe EarlyDerivSpec)
 424 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
 425   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
 426   = do  {       -- Make tc_app saturated, because that's what the
 427                 -- mkDataTypeEqn things expect
 428                 -- It might not be saturated in the standalone deriving case
 429                 --      derive instance Monad (T a)
 430           let extra_tvs = dropList tc_args (tyConTyVars tycon)
 431               full_tc_args = tc_args ++ mkTyVarTys extra_tvs
 432               full_tvs = tvs ++ extra_tvs
 433
 434         ; (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon full_tc_args
 435
 436         ; mayDeriveDataTypeable <- doptM Opt_DeriveDataTypeable
 437         ; newtype_deriving <- doptM Opt_GeneralizedNewtypeDeriving
 438
 439           -- Be careful to test rep_tc here: in the case of families, we want
 440           -- to check the instance tycon, not the family tycon
 441         ; if isDataTyCon rep_tc then
 442                 mkDataTypeEqn orig mayDeriveDataTypeable full_tvs cls cls_tys
 443                               tycon full_tc_args rep_tc rep_tc_args mtheta
 444           else
 445                 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving
 446                              full_tvs cls cls_tys
 447                              tycon full_tc_args rep_tc rep_tc_args mtheta }
 448   | otherwise
 449   = baleOut (derivingThingErr cls cls_tys tc_app
 450                 (ptext SLIT("Last argument of the instance must be a type application")))
 451
 452 baleOut :: Message -> TcM (Maybe a)
 453 baleOut err = do { addErrTc err;  return Nothing }
 454 \end{code}
 455
 456 Auxiliary lookup wrapper which requires that looked up family instances are
 457 not type instances.  If called with a vanilla tycon, the old type application
 458 is simply returned.
 459
 460 \begin{code}
 461 tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
 462 tcLookupFamInstExact tycon tys
 463   | not (isOpenTyCon tycon)
 464   = return (tycon, tys)
 465   | otherwise
 466   = do { maybeFamInst <- tcLookupFamInst tycon tys
 467        ; case maybeFamInst of
 468            Nothing                     -> famInstNotFound tycon tys False
 469            Just famInst@(_, rep_tys)
 470              | not variable_only_subst -> famInstNotFound tycon tys True
 471              | otherwise               -> return famInst
 472              where
 473                tvs                  = map (Type.getTyVar
 474                                              "TcDeriv.tcLookupFamInstExact")
 475                                           rep_tys
 476                variable_only_subst  = all Type.isTyVarTy rep_tys &&
 477                                       sizeVarSet (mkVarSet tvs) == length tvs
 478                                         -- renaming may have no repetitions
 479        }
 480 \end{code}
 481
 482
 483 %************************************************************************
 484 %*                                                                      *
 485                 Deriving data types
 486 %*                                                                      *
 487 %************************************************************************
 488
 489 \begin{code}
 490 mkDataTypeEqn :: InstOrigin -> Bool -> [Var] -> Class -> [Type]
 491               -> TyCon -> [Type] -> TyCon -> [Type] -> Maybe ThetaType
 492               -> TcRn (Maybe EarlyDerivSpec)    -- Return 'Nothing' if error
 493
 494 mkDataTypeEqn orig mayDeriveDataTypeable tvs cls cls_tys
 495               tycon tc_args rep_tc rep_tc_args mtheta
 496   | Just err <- checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
 497         -- NB: pass the *representation* tycon to checkSideConditions
 498   = baleOut (derivingThingErr cls cls_tys (mkTyConApp tycon tc_args) err)
 499
 500   | otherwise
 501   = ASSERT( null cls_tys )
 502     mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 503
 504 mk_data_eqn :: InstOrigin -> [TyVar] -> Class
 505             -> TyCon -> [TcType] -> TyCon -> [TcType] -> Maybe ThetaType
 506             -> TcM (Maybe EarlyDerivSpec)
 507 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 508   | cls `hasKey` typeableClassKey
 509   =     -- The Typeable class is special in several ways
 510         --        data T a b = ... deriving( Typeable )
 511         -- gives
 512         --        instance Typeable2 T where ...
 513         -- Notice that:
 514         -- 1. There are no constraints in the instance
 515         -- 2. There are no type variables either
 516         -- 3. The actual class we want to generate isn't necessarily
 517         --      Typeable; it depends on the arity of the type
 518     do  { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
 519         ; dfun_name <- new_dfun_name real_clas tycon
 520         ; loc <- getSrcSpanM
 521         ; return (Just $ Right $
 522                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
 523                      , ds_cls = real_clas, ds_tys = [mkTyConApp tycon []]
 524                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
 525
 526   | otherwise
 527   = do  { dfun_name <- new_dfun_name cls tycon
 528         ; loc <- getSrcSpanM
 529         ; let ordinary_constraints
 530                 = [ mkClassPred cls [arg_ty]
 531                   | data_con <- tyConDataCons rep_tc,
 532                     arg_ty   <- ASSERT( isVanillaDataCon data_con )
 533                                 dataConInstOrigArgTys data_con rep_tc_args,
 534                     not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 535
 536               stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
 537               stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
 538               all_constraints = stupid_constraints ++ ordinary_constraints
 539                          -- see Note [Data decl contexts] above
 540
 541               spec = DS { ds_loc = loc, ds_orig = orig
 542                         , ds_name = dfun_name, ds_tvs = tvs
 543                         , ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
 544                         , ds_theta =  mtheta `orElse` all_constraints
 545                         , ds_newtype = False }
 546
 547         ; return (if isJust mtheta then Just (Right spec)       -- Specified context
 548                                    else Just (Left spec)) }     -- Infer context
 549
 550 ------------------------------------------------------------------
 551 -- Check side conditions that dis-allow derivability for particular classes
 552 -- This is *apart* from the newtype-deriving mechanism
 553 --
 554 -- Here we get the representation tycon in case of family instances as it has
 555 -- the data constructors - but we need to be careful to fall back to the
 556 -- family tycon (with indexes) in error messages.
 557
 558 checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> Maybe SDoc
 559 checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
 560   | notNull cls_tys
 561   = Just ty_args_why    -- e.g. deriving( Foo s )
 562   | otherwise
 563   = case [cond | (key,cond) <- sideConditions, key == getUnique cls] of
 564         []     -> Just (non_std_why cls)
 565         [cond] -> cond (mayDeriveDataTypeable, rep_tc)
 566         _other -> pprPanic "checkSideConditions" (ppr cls)
 567   where
 568     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("is not a class")
 569
 570 non_std_why :: Class -> SDoc
 571 non_std_why cls = quotes (ppr cls) <+> ptext SLIT("is not a derivable class")
 572
 573 sideConditions :: [(Unique, Condition)]
 574 sideConditions
 575   = [   (eqClassKey,       cond_std),
 576         (ordClassKey,      cond_std),
 577         (readClassKey,     cond_std),
 578         (showClassKey,     cond_std),
 579         (enumClassKey,     cond_std `andCond` cond_isEnumeration),
 580         (ixClassKey,       cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
 581         (boundedClassKey,  cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
 582         (typeableClassKey, cond_mayDeriveDataTypeable `andCond` cond_typeableOK),
 583         (dataClassKey,     cond_mayDeriveDataTypeable `andCond` cond_std)
 584     ]
 585
 586 type Condition = (Bool, TyCon) -> Maybe SDoc
 587         -- Bool is whether or not we are allowed to derive Data and Typeable
 588         -- TyCon is the *representation* tycon if the
 589         --      data type is an indexed one
 590         -- Nothing => OK
 591
 592 orCond :: Condition -> Condition -> Condition
 593 orCond c1 c2 tc
 594   = case c1 tc of
 595         Nothing -> Nothing              -- c1 succeeds
 596         Just x  -> case c2 tc of        -- c1 fails
 597                      Nothing -> Nothing
 598                      Just y  -> Just (x $$ ptext SLIT("  and") $$ y)
 599                                         -- Both fail
 600
 601 andCond :: Condition -> Condition -> Condition
 602 andCond c1 c2 tc = case c1 tc of
 603                      Nothing -> c2 tc   -- c1 succeeds
 604                      Just x  -> Just x  -- c1 fails
 605
 606 cond_std :: Condition
 607 cond_std (_, rep_tc)
 608   | any (not . isVanillaDataCon) data_cons = Just existential_why
 609   | null data_cons                         = Just no_cons_why
 610   | otherwise                              = Nothing
 611   where
 612     data_cons       = tyConDataCons rep_tc
 613     no_cons_why     = quotes (pprSourceTyCon rep_tc) <+>
 614                       ptext SLIT("has no data constructors")
 615     existential_why = quotes (pprSourceTyCon rep_tc) <+>
 616                       ptext SLIT("has non-Haskell-98 constructor(s)")
 617
 618 cond_isEnumeration :: Condition
 619 cond_isEnumeration (_, rep_tc)
 620   | isEnumerationTyCon rep_tc = Nothing
 621   | otherwise                 = Just why
 622   where
 623     why = quotes (pprSourceTyCon rep_tc) <+>
 624           ptext SLIT("has non-nullary constructors")
 625
 626 cond_isProduct :: Condition
 627 cond_isProduct (_, rep_tc)
 628   | isProductTyCon rep_tc = Nothing
 629   | otherwise             = Just why
 630   where
 631     why = quotes (pprSourceTyCon rep_tc) <+>
 632           ptext SLIT("has more than one constructor")
 633
 634 cond_typeableOK :: Condition
 635 -- OK for Typeable class
 636 -- Currently: (a) args all of kind *
 637 --            (b) 7 or fewer args
 638 cond_typeableOK (_, rep_tc)
 639   | tyConArity rep_tc > 7       = Just too_many
 640   | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
 641                                 = Just bad_kind
 642   | isFamInstTyCon rep_tc       = Just fam_inst  -- no Typable for family insts
 643   | otherwise                   = Nothing
 644   where
 645     too_many = quotes (pprSourceTyCon rep_tc) <+>
 646                ptext SLIT("has too many arguments")
 647     bad_kind = quotes (pprSourceTyCon rep_tc) <+>
 648                ptext SLIT("has arguments of kind other than `*'")
 649     fam_inst = quotes (pprSourceTyCon rep_tc) <+>
 650                ptext SLIT("is a type family")
 651
 652 cond_mayDeriveDataTypeable :: Condition
 653 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
 654  | mayDeriveDataTypeable = Nothing
 655  | otherwise = Just why
 656   where
 657     why  = ptext SLIT("You need -XDeriveDataTypeable to derive an instance for this class")
 658
 659 std_class_via_iso :: Class -> Bool
 660 std_class_via_iso clas  -- These standard classes can be derived for a newtype
 661                         -- using the isomorphism trick *even if no -fglasgow-exts*
 662   = classKey clas `elem`  [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
 663         -- Not Read/Show because they respect the type
 664         -- Not Enum, because newtypes are never in Enum
 665
 666
 667 new_dfun_name :: Class -> TyCon -> TcM Name
 668 new_dfun_name clas tycon        -- Just a simple wrapper
 669   = newDFunName clas [mkTyConApp tycon []] (getSrcSpan tycon)
 670         -- The type passed to newDFunName is only used to generate
 671         -- a suitable string; hence the empty type arg list
 672 \end{code}
 673
 674
 675 %************************************************************************
 676 %*                                                                      *
 677                 Deriving newtypes
 678 %*                                                                      *
 679 %************************************************************************
 680
 681 \begin{code}
 682 mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
 683              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
 684              -> Maybe ThetaType
 685              -> TcRn (Maybe EarlyDerivSpec)
 686 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
 687              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
 688   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
 689   = do  { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
 690         ; dfun_name <- new_dfun_name cls tycon
 691         ; loc <- getSrcSpanM
 692         ; let spec = DS { ds_loc = loc, ds_orig = orig
 693                         , ds_name = dfun_name, ds_tvs = dict_tvs
 694                         , ds_cls = cls, ds_tys = inst_tys
 695                         , ds_theta =  mtheta `orElse` all_preds
 696                         , ds_newtype = True }
 697         ; return (if isJust mtheta then Just (Right spec)
 698                                    else Just (Left spec)) }
 699
 700   | isNothing mb_std_err        -- Use the standard H98 method
 701   = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
 702
 703         -- Otherwise we can't derive
 704   | newtype_deriving = baleOut cant_derive_err -- Too hard
 705   | otherwise        = baleOut std_err          -- Just complain about being a non-std instance
 706   where
 707         mb_std_err = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
 708         std_err = derivingThingErr cls cls_tys tc_app $
 709                   vcat [fromJust mb_std_err,
 710                         ptext SLIT("Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")]
 711
 712         -- Here is the plan for newtype derivings.  We see
 713         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
 714         -- where t is a type,
 715         --       ak+1...an is a suffix of a1..an, and are all tyars
 716         --       ak+1...an do not occur free in t, nor in the s1..sm
 717         --       (C s1 ... sm) is a  *partial applications* of class C
 718         --                      with the last parameter missing
 719         --       (T a1 .. ak) matches the kind of C's last argument
 720         --              (and hence so does t)
 721         --
 722         -- We generate the instance
 723         --       instance forall ({a1..ak} u fvs(s1..sm)).
 724         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
 725         -- where T a1...ap is the partial application of
 726         --       the LHS of the correct kind and p >= k
 727         --
 728         --      NB: the variables below are:
 729         --              tc_tvs = [a1, ..., an]
 730         --              tyvars_to_keep = [a1, ..., ak]
 731         --              rep_ty = t ak .. an
 732         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
 733         --              tys = [s1, ..., sm]
 734         --              rep_fn' = t
 735         --
 736         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
 737         -- We generate the instance
 738         --      instance Monad (ST s) => Monad (T s) where
 739
 740         cls_tyvars = classTyVars cls
 741         kind = tyVarKind (last cls_tyvars)
 742                 -- Kind of the thing we want to instance
 743                 --   e.g. argument kind of Monad, *->*
 744
 745         (arg_kinds, _) = splitKindFunTys kind
 746         n_args_to_drop = length arg_kinds
 747                 -- Want to drop 1 arg from (T s a) and (ST s a)
 748                 -- to get       instance Monad (ST s) => Monad (T s)
 749
 750         -- Note [newtype representation]
 751         -- Need newTyConRhs *not* newTyConRep to get the representation
 752         -- type, because the latter looks through all intermediate newtypes
 753         -- For example
 754         --      newtype B = MkB Int
 755         --      newtype A = MkA B deriving( Num )
 756         -- We want the Num instance of B, *not* the Num instance of Int,
 757         -- when making the Num instance of A!
 758         rep_ty                = newTyConInstRhs rep_tycon rep_tc_args
 759         (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
 760
 761         n_tyargs_to_keep = tyConArity tycon - n_args_to_drop
 762         dropped_tc_args = drop n_tyargs_to_keep tc_args
 763         dropped_tvs     = tyVarsOfTypes dropped_tc_args
 764
 765         n_args_to_keep = length rep_ty_args - n_args_to_drop
 766         args_to_drop   = drop n_args_to_keep rep_ty_args
 767         args_to_keep   = take n_args_to_keep rep_ty_args
 768
 769         rep_fn'  = mkAppTys rep_fn args_to_keep
 770         rep_tys  = cls_tys ++ [rep_fn']
 771         rep_pred = mkClassPred cls rep_tys
 772                 -- rep_pred is the representation dictionary, from where
 773                 -- we are gong to get all the methods for the newtype
 774                 -- dictionary
 775
 776         tc_app = mkTyConApp tycon (take n_tyargs_to_keep tc_args)
 777
 778     -- Next we figure out what superclass dictionaries to use
 779     -- See Note [Newtype deriving superclasses] above
 780
 781         inst_tys = cls_tys ++ [tc_app]
 782         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
 783                               (classSCTheta cls)
 784
 785                 -- If there are no tyvars, there's no need
 786                 -- to abstract over the dictionaries we need
 787                 -- Example:     newtype T = MkT Int deriving( C )
 788                 -- We get the derived instance
 789                 --              instance C T
 790                 -- rather than
 791                 --              instance C Int => C T
 792         dict_tvs = filterOut (`elemVarSet` dropped_tvs) tvs
 793         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
 794
 795         -------------------------------------------------------------------
 796         --  Figuring out whether we can only do this newtype-deriving thing
 797
 798         right_arity = length cls_tys + 1 == classArity cls
 799
 800                 -- Never derive Read,Show,Typeable,Data this way
 801         non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
 802         can_derive_via_isomorphism
 803            =  not (getUnique cls `elem` non_iso_classes)
 804            && right_arity                       -- Well kinded;
 805                                                 -- eg not: newtype T ... deriving( ST )
 806                                                 --      because ST needs *2* type params
 807            && n_tyargs_to_keep >= 0             -- Type constructor has right kind:
 808                                                 -- eg not: newtype T = T Int deriving( Monad )
 809            && n_args_to_keep   >= 0             -- Rep type has right kind:
 810                                                 -- eg not: newtype T a = T Int deriving( Monad )
 811            && eta_ok                            -- Eta reduction works
 812            && not (isRecursiveTyCon tycon)      -- Does not work for recursive tycons:
 813                                                 --      newtype A = MkA [A]
 814                                                 -- Don't want
 815                                                 --      instance Eq [A] => Eq A !!
 816                         -- Here's a recursive newtype that's actually OK
 817                         --      newtype S1 = S1 [T1 ()]
 818                         --      newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
 819                         -- It's currently rejected.  Oh well.
 820                         -- In fact we generate an instance decl that has method of form
 821                         --      meth @ instTy = meth @ repTy
 822                         -- (no coerce's).  We'd need a coerce if we wanted to handle
 823                         -- recursive newtypes too
 824
 825         -- Check that eta reduction is OK
 826         eta_ok = (args_to_drop `tcEqTypes` dropped_tc_args)
 827                 -- (a) the dropped-off args are identical in the source and rep type
 828                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
 829                 --     Here the 'b' must be the same in the rep type (S [a] b)
 830
 831               && (tyVarsOfType rep_fn' `disjointVarSet` dropped_tvs)
 832                 -- (b) the remaining type args do not mention any of the dropped
 833                 --     type variables
 834
 835               && (tyVarsOfTypes cls_tys `disjointVarSet` dropped_tvs)
 836                 -- (c) the type class args do not mention any of the dropped type
 837                 --     variables
 838
 839               && all isTyVarTy dropped_tc_args
 840                 -- (d) in case of newtype family instances, the eta-dropped
 841                 --      arguments must be type variables (not more complex indexes)
 842
 843         cant_derive_err = derivingThingErr cls cls_tys tc_app
 844                                 (vcat [ptext SLIT("even with cunning newtype deriving:"),
 845                                         if isRecursiveTyCon tycon then
 846                                           ptext SLIT("the newtype may be recursive")
 847                                         else empty,
 848                                         if not right_arity then
 849                                           quotes (ppr (mkClassPred cls cls_tys)) <+> ptext SLIT("does not have arity 1")
 850                                         else empty,
 851                                         if not (n_tyargs_to_keep >= 0) then
 852                                           ptext SLIT("the type constructor has wrong kind")
 853                                         else if not (n_args_to_keep >= 0) then
 854                                           ptext SLIT("the representation type has wrong kind")
 855                                         else if not eta_ok then
 856                                           ptext SLIT("the eta-reduction property does not hold")
 857                                         else empty
 858                                       ])
 859 \end{code}
 860
 861
 862 %************************************************************************
 863 %*                                                                      *
 864 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 865 %*                                                                      *
 866 %************************************************************************
 867
 868 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 869 terms, which is the final correct RHS for the corresponding original
 870 equation.
 871 \begin{itemize}
 872 \item
 873 Each (k,TyVarTy tv) in a solution constrains only a type
 874 variable, tv.
 875
 876 \item
 877 The (k,TyVarTy tv) pairs in a solution are canonically
 878 ordered by sorting on type varible, tv, (major key) and then class, k,
 879 (minor key)
 880 \end{itemize}
 881
 882 \begin{code}
 883 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
 884
 885 inferInstanceContexts _ [] = return []
 886
 887 inferInstanceContexts oflag infer_specs
 888   = do  { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
 889         ; iterate_deriv 1 initial_solutions }
 890   where
 891     ------------------------------------------------------------------
 892         -- The initial solutions for the equations claim that each
 893         -- instance has an empty context; this solution is certainly
 894         -- in canonical form.
 895     initial_solutions :: [ThetaType]
 896     initial_solutions = [ [] | _ <- infer_specs ]
 897
 898     ------------------------------------------------------------------
 899         -- iterate_deriv calculates the next batch of solutions,
 900         -- compares it with the current one; finishes if they are the
 901         -- same, otherwise recurses with the new solutions.
 902         -- It fails if any iteration fails
 903     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
 904     iterate_deriv n current_solns
 905       | n > 20  -- Looks as if we are in an infinite loop
 906                 -- This can happen if we have -fallow-undecidable-instances
 907                 -- (See TcSimplify.tcSimplifyDeriv.)
 908       = pprPanic "solveDerivEqns: probable loop"
 909                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
 910       | otherwise
 911       = do {      -- Extend the inst info from the explicit instance decls
 912                   -- with the current set of solutions, and simplify each RHS
 913              let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag)
 914                                            current_solns infer_specs
 915            ; new_solns <- checkNoErrs $
 916                           extendLocalInstEnv inst_specs $
 917                           mapM gen_soln infer_specs
 918
 919            ; if (current_solns == new_solns) then
 920                 return [ spec { ds_theta = soln }
 921                        | (spec, soln) <- zip infer_specs current_solns ]
 922              else
 923                 iterate_deriv (n+1) new_solns }
 924
 925     ------------------------------------------------------------------
 926     gen_soln :: DerivSpec  -> TcM [PredType]
 927     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
 928                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
 929       = setSrcSpan loc  $
 930         addErrCtxt (derivInstCtxt clas inst_tys) $
 931         do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
 932                 -- checkValidInstance tyvars theta clas inst_tys
 933                 -- Not necessary; see Note [Exotic derived instance contexts]
 934                 --                in TcSimplify
 935
 936                   -- Check for a bizarre corner case, when the derived instance decl should
 937                   -- have form  instance C a b => D (T a) where ...
 938                   -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
 939                   -- of problems; in particular, it's hard to compare solutions for
 940                   -- equality when finding the fixpoint.  So I just rule it out for now.
 941            ; let tv_set = mkVarSet tyvars
 942                  weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
 943            ; mapM_ (addErrTc . badDerivedPred) weird_preds
 944
 945                 -- Claim: the result instance declaration is guaranteed valid
 946                 -- Hence no need to call:
 947                 --   checkValidInstance tyvars theta clas inst_tys
 948            ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution
 949
 950 ------------------------------------------------------------------
 951 mkInstance1 :: OverlapFlag -> DerivSpec -> Instance
 952 mkInstance1 overlap_flag spec = mkInstance2 overlap_flag (ds_theta spec) spec
 953
 954 mkInstance2 :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
 955 mkInstance2 overlap_flag theta
 956             (DS { ds_name = dfun_name
 957                 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
 958   = mkLocalInstance dfun overlap_flag
 959   where
 960     dfun = mkDictFunId dfun_name tyvars theta clas tys
 961
 962
 963 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
 964 -- Add new locally-defined instances; don't bother to check
 965 -- for functional dependency errors -- that'll happen in TcInstDcls
 966 extendLocalInstEnv dfuns thing_inside
 967  = do { env <- getGblEnv
 968       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
 969              env'      = env { tcg_inst_env = inst_env' }
 970       ; setGblEnv env' thing_inside }
 971 \end{code}
 972
 973
 974 %************************************************************************
 975 %*                                                                      *
 976 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 977 %*                                                                      *
 978 %************************************************************************
 979
 980 After all the trouble to figure out the required context for the
 981 derived instance declarations, all that's left is to chug along to
 982 produce them.  They will then be shoved into @tcInstDecls2@, which
 983 will do all its usual business.
 984
 985 There are lots of possibilities for code to generate.  Here are
 986 various general remarks.
 987
 988 PRINCIPLES:
 989 \begin{itemize}
 990 \item
 991 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 992 ``you-couldn't-do-better-by-hand'' efficient.
 993
 994 \item
 995 Deriving @Show@---also pretty common--- should also be reasonable good code.
 996
 997 \item
 998 Deriving for the other classes isn't that common or that big a deal.
 999 \end{itemize}
1000
1001 PRAGMATICS:
1002
1003 \begin{itemize}
1004 \item
1005 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1006
1007 \item
1008 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1009
1010 \item
1011 We {\em normally} generate code only for the non-defaulted methods;
1012 there are some exceptions for @Eq@ and (especially) @Ord@...
1013
1014 \item
1015 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1016 constructor's numeric (@Int#@) tag.  These are generated by
1017 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1018 these is around is given by @hasCon2TagFun@.
1019
1020 The examples under the different sections below will make this
1021 clearer.
1022
1023 \item
1024 Much less often (really just for deriving @Ix@), we use a
1025 @_tag2con_<tycon>@ function.  See the examples.
1026
1027 \item
1028 We use the renamer!!!  Reason: we're supposed to be
1029 producing @LHsBinds Name@ for the methods, but that means
1030 producing correctly-uniquified code on the fly.  This is entirely
1031 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1032 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1033 the renamer.  What a great hack!
1034 \end{itemize}
1035
1036 \begin{code}
1037 -- Generate the InstInfo for the required instance paired with the
1038 --   *representation* tycon for that instance,
1039 -- plus any auxiliary bindings required
1040 --
1041 -- Representation tycons differ from the tycon in the instance signature in
1042 -- case of instances for indexed families.
1043 --
1044 genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo, DerivAuxBinds)
1045 genInst oflag spec
1046   | ds_newtype spec
1047   = return (InstInfo { iSpec = mkInstance1 oflag spec
1048                      , iBinds = NewTypeDerived }, [])
1049
1050   | otherwise
1051   = do  { fix_env <- getFixityEnv
1052         ; let
1053             inst                    = mkInstance1 oflag spec
1054             (tyvars,_,clas,[ty])    = instanceHead inst
1055             clas_nm                 = className clas
1056             (visible_tycon, tyArgs) = tcSplitTyConApp ty
1057
1058           -- In case of a family instance, we need to use the representation
1059           -- tycon (after all, it has the data constructors)
1060         ; (tycon, _) <- tcLookupFamInstExact visible_tycon tyArgs
1061         ; let (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon
1062
1063         -- Bring the right type variables into
1064         -- scope, and rename the method binds
1065         -- It's a bit yukky that we return *renamed* InstInfo, but
1066         -- *non-renamed* auxiliary bindings
1067         ; (rn_meth_binds, _fvs) <- discardWarnings $
1068                                    bindLocalNames (map Var.varName tyvars) $
1069                                    rnMethodBinds clas_nm (\_ -> []) [] meth_binds
1070
1071         -- Build the InstInfo
1072         ; return (InstInfo { iSpec = inst,
1073                              iBinds = VanillaInst rn_meth_binds [] },
1074                   aux_binds)
1075         }
1076
1077 genDerivBinds :: Class -> FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1078 genDerivBinds clas fix_env tycon
1079   | className clas `elem` typeableClassNames
1080   = (gen_Typeable_binds tycon, [])
1081
1082   | otherwise
1083   = case assocMaybe gen_list (getUnique clas) of
1084         Just gen_fn -> gen_fn tycon
1085         Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1086   where
1087     gen_list :: [(Unique, TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1088     gen_list = [(eqClassKey,       gen_Eq_binds)
1089                ,(ordClassKey,      gen_Ord_binds)
1090                ,(enumClassKey,     gen_Enum_binds)
1091                ,(boundedClassKey,  gen_Bounded_binds)
1092                ,(ixClassKey,       gen_Ix_binds)
1093                ,(showClassKey,     gen_Show_binds fix_env)
1094                ,(readClassKey,     gen_Read_binds fix_env)
1095                ,(dataClassKey,     gen_Data_binds fix_env)
1096                ]
1097 \end{code}
1098
1099
1100 %************************************************************************
1101 %*                                                                      *
1102 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1103 %*                                                                      *
1104 %************************************************************************
1105
1106 \begin{code}
1107 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
1108 derivingThingErr clas tys ty why
1109   = sep [hsep [ptext SLIT("Can't make a derived instance of"),
1110                quotes (ppr pred)],
1111          nest 2 (parens why)]
1112   where
1113     pred = mkClassPred clas (tys ++ [ty])
1114
1115 standaloneCtxt :: LHsType Name -> SDoc
1116 standaloneCtxt ty = ptext SLIT("In the stand-alone deriving instance for") <+> quotes (ppr ty)
1117
1118 derivInstCtxt :: Class -> [Type] -> Message
1119 derivInstCtxt clas inst_tys
1120   = ptext SLIT("When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1121
1122 badDerivedPred :: PredType -> Message
1123 badDerivedPred pred
1124   = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
1125           ptext SLIT("type variables that are not data type parameters"),
1126           nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
1127
1128 famInstNotFound :: TyCon -> [Type] -> Bool -> TcM a
1129 famInstNotFound tycon tys notExact
1130   = failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
1131   where
1132     msg = ptext $ if notExact
1133                   then SLIT("No family instance exactly matching")
1134                   else SLIT("More than one family instance for")
1135 \end{code}