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