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