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