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