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 (mkNameSet 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) ]
 619                         -- No constraints for unlifted types
 620                         -- Where they are legal we generate specilised function calls
 621
 622                         -- See Note [Superclasses of derived instance]
 623               sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
 624                                           (classSCTheta cls)
 625               inst_tys = [mkTyConApp tycon tc_args]
 626
 627               stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
 628               stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
 629               all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
 630
 631               spec = DS { ds_loc = loc, ds_orig = orig
 632                         , ds_name = dfun_name, ds_tvs = tvs
 633                         , ds_cls = cls, ds_tys = inst_tys, ds_tc = rep_tc
 634                         , ds_theta =  mtheta `orElse` all_constraints
 635                         , ds_newtype = False }
 636
 637         ; return (if isJust mtheta then Right spec      -- Specified context
 638                                    else Left spec) }    -- Infer context
 639
 640 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
 641         -- The Typeable class is special in several ways
 642         --        data T a b = ... deriving( Typeable )
 643         -- gives
 644         --        instance Typeable2 T where ...
 645         -- Notice that:
 646         -- 1. There are no constraints in the instance
 647         -- 2. There are no type variables either
 648         -- 3. The actual class we want to generate isn't necessarily
 649         --      Typeable; it depends on the arity of the type
 650   | isNothing mtheta    -- deriving on a data type decl
 651   = do  { checkTc (cls `hasKey` typeableClassKey)
 652                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
 653         ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
 654         ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
 655
 656   | otherwise           -- standaone deriving
 657   = do  { checkTc (null tc_args)
 658                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
 659                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
 660         ; dfun_name <- new_dfun_name cls tycon
 661         ; loc <- getSrcSpanM
 662         ; return (Right $
 663                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
 664                      , ds_cls = cls, ds_tys = [mkTyConApp tycon []], ds_tc = rep_tc
 665                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
 666
 667 ------------------------------------------------------------------
 668 -- Check side conditions that dis-allow derivability for particular classes
 669 -- This is *apart* from the newtype-deriving mechanism
 670 --
 671 -- Here we get the representation tycon in case of family instances as it has
 672 -- the data constructors - but we need to be careful to fall back to the
 673 -- family tycon (with indexes) in error messages.
 674
 675 data DerivStatus = CanDerive
 676                  | NonDerivableClass
 677                  | DerivableClassError SDoc
 678
 679 checkSideConditions :: Bool -> Class -> [TcType] -> TyCon -> DerivStatus
 680 checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tc
 681   | notNull cls_tys
 682   = DerivableClassError ty_args_why     -- e.g. deriving( Foo s )
 683   | otherwise
 684   = case sideConditions cls of
 685         Nothing   -> NonDerivableClass
 686         Just cond -> case (cond (mayDeriveDataTypeable, rep_tc)) of
 687                         Nothing  -> CanDerive
 688                         Just err -> DerivableClassError err
 689   where
 690     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
 691
 692 nonStdErr :: Class -> SDoc
 693 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
 694
 695 sideConditions :: Class -> Maybe Condition
 696 sideConditions cls
 697   | cls_key == eqClassKey      = Just cond_std
 698   | cls_key == ordClassKey     = Just cond_std
 699   | cls_key == showClassKey    = Just cond_std
 700   | cls_key == readClassKey    = Just (cond_std `andCond` cond_noUnliftedArgs)
 701   | cls_key == enumClassKey    = Just (cond_std `andCond` cond_isEnumeration)
 702   | cls_key == ixClassKey      = Just (cond_std `andCond` cond_enumOrProduct)
 703   | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct)
 704   | cls_key == dataClassKey    = Just (cond_mayDeriveDataTypeable `andCond` cond_std `andCond` cond_noUnliftedArgs)
 705   | getName cls `elem` typeableClassNames = Just (cond_mayDeriveDataTypeable `andCond` cond_typeableOK)
 706   | otherwise = Nothing
 707   where
 708     cls_key = getUnique cls
 709
 710 type Condition = (Bool, TyCon) -> Maybe SDoc
 711         -- Bool is whether or not we are allowed to derive Data and Typeable
 712         -- TyCon is the *representation* tycon if the
 713         --      data type is an indexed one
 714         -- Nothing => OK
 715
 716 orCond :: Condition -> Condition -> Condition
 717 orCond c1 c2 tc
 718   = case c1 tc of
 719         Nothing -> Nothing              -- c1 succeeds
 720         Just x  -> case c2 tc of        -- c1 fails
 721                      Nothing -> Nothing
 722                      Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
 723                                         -- Both fail
 724
 725 andCond :: Condition -> Condition -> Condition
 726 andCond c1 c2 tc = case c1 tc of
 727                      Nothing -> c2 tc   -- c1 succeeds
 728                      Just x  -> Just x  -- c1 fails
 729
 730 cond_std :: Condition
 731 cond_std (_, rep_tc)
 732   | any (not . isVanillaDataCon) data_cons = Just existential_why
 733   | null data_cons                         = Just no_cons_why
 734   | otherwise                              = Nothing
 735   where
 736     data_cons       = tyConDataCons rep_tc
 737     no_cons_why     = quotes (pprSourceTyCon rep_tc) <+>
 738                       ptext (sLit "has no data constructors")
 739     existential_why = quotes (pprSourceTyCon rep_tc) <+>
 740                       ptext (sLit "has non-Haskell-98 constructor(s)")
 741
 742 cond_enumOrProduct :: Condition
 743 cond_enumOrProduct = cond_isEnumeration `orCond`
 744                        (cond_isProduct `andCond` cond_noUnliftedArgs)
 745
 746 cond_noUnliftedArgs :: Condition
 747 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 748 -- by generating specilaised code.  For others (eg Data) we don't.
 749 cond_noUnliftedArgs (_, tc)
 750   | null bad_cons = Nothing
 751   | otherwise     = Just why
 752   where
 753     bad_cons = [ con | con <- tyConDataCons tc
 754                      , any isUnLiftedType (dataConOrigArgTys con) ]
 755     why = ptext (sLit "Constructor") <+> quotes (ppr (head bad_cons))
 756           <+> ptext (sLit "has arguments of unlifted type")
 757
 758 cond_isEnumeration :: Condition
 759 cond_isEnumeration (_, rep_tc)
 760   | isEnumerationTyCon rep_tc = Nothing
 761   | otherwise                 = Just why
 762   where
 763     why = quotes (pprSourceTyCon rep_tc) <+>
 764           ptext (sLit "has non-nullary constructors")
 765
 766 cond_isProduct :: Condition
 767 cond_isProduct (_, rep_tc)
 768   | isProductTyCon rep_tc = Nothing
 769   | otherwise             = Just why
 770   where
 771     why = quotes (pprSourceTyCon rep_tc) <+>
 772           ptext (sLit "has more than one constructor")
 773
 774 cond_typeableOK :: Condition
 775 -- OK for Typeable class
 776 -- Currently: (a) args all of kind *
 777 --            (b) 7 or fewer args
 778 cond_typeableOK (_, rep_tc)
 779   | tyConArity rep_tc > 7       = Just too_many
 780   | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
 781                                 = Just bad_kind
 782   | isFamInstTyCon rep_tc       = Just fam_inst  -- no Typable for family insts
 783   | otherwise                   = Nothing
 784   where
 785     too_many = quotes (pprSourceTyCon rep_tc) <+>
 786                ptext (sLit "has too many arguments")
 787     bad_kind = quotes (pprSourceTyCon rep_tc) <+>
 788                ptext (sLit "has arguments of kind other than `*'")
 789     fam_inst = quotes (pprSourceTyCon rep_tc) <+>
 790                ptext (sLit "is a type family")
 791
 792 cond_mayDeriveDataTypeable :: Condition
 793 cond_mayDeriveDataTypeable (mayDeriveDataTypeable, _)
 794  | mayDeriveDataTypeable = Nothing
 795  | otherwise = Just why
 796   where
 797     why  = ptext (sLit "You need -XDeriveDataTypeable to derive an instance for this class")
 798
 799 std_class_via_iso :: Class -> Bool
 800 std_class_via_iso clas  -- These standard classes can be derived for a newtype
 801                         -- using the isomorphism trick *even if no -fglasgow-exts*
 802   = classKey clas `elem`  [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
 803         -- Not Read/Show because they respect the type
 804         -- Not Enum, because newtypes are never in Enum
 805
 806
 807 new_dfun_name :: Class -> TyCon -> TcM Name
 808 new_dfun_name clas tycon        -- Just a simple wrapper
 809   = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
 810         ; newDFunName clas [mkTyConApp tycon []] loc }
 811         -- The type passed to newDFunName is only used to generate
 812         -- a suitable string; hence the empty type arg list
 813 \end{code}
 814
 815 Note [Superclasses of derived instance]
 816 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 817 In general, a derived instance decl needs the superclasses of the derived
 818 class too.  So if we have
 819         data T a = ...deriving( Ord )
 820 then the initial context for Ord (T a) should include Eq (T a).  Often this is
 821 redundant; we'll also generate an Ord constraint for each constructor argument,
 822 and that will probably generate enough constraints to make the Eq (T a) constraint
 823 be satisfied too.  But not always; consider:
 824
 825  data S a = S
 826  instance Eq (S a)
 827  instance Ord (S a)
 828
 829  data T a = MkT (S a) deriving( Ord )
 830  instance Num a => Eq (T a)
 831
 832 The derived instance for (Ord (T a)) must have a (Num a) constraint!
 833 Similarly consider:
 834         data T a = MkT deriving( Data, Typeable )
 835 Here there *is* no argument field, but we must nevertheless generate
 836 a context for the Data instances:
 837         instance Typable a => Data (T a) where ...
 838
 839
 840 %************************************************************************
 841 %*                                                                      *
 842                 Deriving newtypes
 843 %*                                                                      *
 844 %************************************************************************
 845
 846 \begin{code}
 847 mkNewTypeEqn :: InstOrigin -> Bool -> Bool -> [Var] -> Class
 848              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
 849              -> Maybe ThetaType
 850              -> TcRn EarlyDerivSpec
 851 mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
 852              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
 853   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
 854   = do  { traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
 855         ; dfun_name <- new_dfun_name cls tycon
 856         ; loc <- getSrcSpanM
 857         ; let spec = DS { ds_loc = loc, ds_orig = orig
 858                         , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
 859                         , ds_cls = cls, ds_tys = inst_tys, ds_tc = rep_tycon
 860                         , ds_theta =  mtheta `orElse` all_preds
 861                         , ds_newtype = True }
 862         ; return (if isJust mtheta then Right spec
 863                                    else Left spec) }
 864
 865   | otherwise
 866   = case check_conditions of
 867       CanDerive -> mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
 868                                 -- Use the standard H98 method
 869       DerivableClassError msg -> bale_out msg              -- Error with standard class
 870       NonDerivableClass         -- Must use newtype deriving
 871         | newtype_deriving    -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
 872         | otherwise           -> bale_out non_std_err      -- Try newtype deriving!
 873   where
 874         check_conditions = checkSideConditions mayDeriveDataTypeable cls cls_tys rep_tycon
 875         bale_out msg = failWithTc (derivingThingErr cls cls_tys inst_ty msg)
 876
 877         non_std_err = nonStdErr cls $$
 878                       ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
 879
 880         -- Here is the plan for newtype derivings.  We see
 881         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
 882         -- where t is a type,
 883         --       ak+1...an is a suffix of a1..an, and are all tyars
 884         --       ak+1...an do not occur free in t, nor in the s1..sm
 885         --       (C s1 ... sm) is a  *partial applications* of class C
 886         --                      with the last parameter missing
 887         --       (T a1 .. ak) matches the kind of C's last argument
 888         --              (and hence so does t)
 889         -- The latter kind-check has been done by deriveTyData already,
 890         -- and tc_args are already trimmed
 891         --
 892         -- We generate the instance
 893         --       instance forall ({a1..ak} u fvs(s1..sm)).
 894         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
 895         -- where T a1...ap is the partial application of
 896         --       the LHS of the correct kind and p >= k
 897         --
 898         --      NB: the variables below are:
 899         --              tc_tvs = [a1, ..., an]
 900         --              tyvars_to_keep = [a1, ..., ak]
 901         --              rep_ty = t ak .. an
 902         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
 903         --              tys = [s1, ..., sm]
 904         --              rep_fn' = t
 905         --
 906         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
 907         -- We generate the instance
 908         --      instance Monad (ST s) => Monad (T s) where
 909
 910         nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
 911                 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
 912                 -- eta-reduces the represenation type, so we know that
 913                 --      T a ~ S a a
 914                 -- That's convenient here, because we may have to apply
 915                 -- it to fewer than its original complement of arguments
 916
 917         -- Note [Newtype representation]
 918         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 919         -- Need newTyConRhs (*not* a recursive representation finder)
 920         -- to get the representation type. For example
 921         --      newtype B = MkB Int
 922         --      newtype A = MkA B deriving( Num )
 923         -- We want the Num instance of B, *not* the Num instance of Int,
 924         -- when making the Num instance of A!
 925         rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
 926         rep_tys     = cls_tys ++ [rep_inst_ty]
 927         rep_pred    = mkClassPred cls rep_tys
 928                 -- rep_pred is the representation dictionary, from where
 929                 -- we are gong to get all the methods for the newtype
 930                 -- dictionary
 931
 932
 933     -- Next we figure out what superclass dictionaries to use
 934     -- See Note [Newtype deriving superclasses] above
 935
 936         cls_tyvars = classTyVars cls
 937         dfun_tvs = tyVarsOfTypes tc_args
 938         inst_ty = mkTyConApp tycon tc_args
 939         inst_tys = cls_tys ++ [inst_ty]
 940         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
 941                               (classSCTheta cls)
 942
 943                 -- If there are no tyvars, there's no need
 944                 -- to abstract over the dictionaries we need
 945                 -- Example:     newtype T = MkT Int deriving( C )
 946                 -- We get the derived instance
 947                 --              instance C T
 948                 -- rather than
 949                 --              instance C Int => C T
 950         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
 951
 952         -------------------------------------------------------------------
 953         --  Figuring out whether we can only do this newtype-deriving thing
 954
 955         right_arity = length cls_tys + 1 == classArity cls
 956
 957                 -- Never derive Read,Show,Typeable,Data this way
 958         non_iso_class cls = className cls `elem` ([readClassName, showClassName, dataClassName] ++
 959                                                   typeableClassNames)
 960         can_derive_via_isomorphism
 961            =  not (non_iso_class cls)
 962            && right_arity                       -- Well kinded;
 963                                                 -- eg not: newtype T ... deriving( ST )
 964                                                 --      because ST needs *2* type params
 965            && eta_ok                            -- Eta reduction works
 966            && not (isRecursiveTyCon tycon)      -- Does not work for recursive tycons:
 967                                                 --      newtype A = MkA [A]
 968                                                 -- Don't want
 969                                                 --      instance Eq [A] => Eq A !!
 970                         -- Here's a recursive newtype that's actually OK
 971                         --      newtype S1 = S1 [T1 ()]
 972                         --      newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
 973                         -- It's currently rejected.  Oh well.
 974                         -- In fact we generate an instance decl that has method of form
 975                         --      meth @ instTy = meth @ repTy
 976                         -- (no coerce's).  We'd need a coerce if we wanted to handle
 977                         -- recursive newtypes too
 978
 979         -- Check that eta reduction is OK
 980         eta_ok = (nt_eta_arity <= length rep_tc_args)
 981                 -- (a) the newtype can be eta-reduced to match the number
 982                 --     of type argument actually supplied
 983                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
 984                 --     Here the 'b' must be the same in the rep type (S [a] b)
 985                 --     And the [a] must not mention 'b'.  That's all handled
 986                 --     by nt_eta_rity.
 987
 988               && (tyVarsOfTypes cls_tys `subVarSet` dfun_tvs)
 989                 -- (c) the type class args do not mention any of the dropped type
 990                 --     variables
 991                 --              newtype T a b = ... deriving( Monad b )
 992
 993         cant_derive_err = vcat [ptext (sLit "even with cunning newtype deriving:"),
 994                                 if isRecursiveTyCon tycon then
 995                                   ptext (sLit "the newtype may be recursive")
 996                                 else empty,
 997                                 if not right_arity then
 998                                   quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
 999                                 else empty,
1000                                 if not eta_ok then
1001                                   ptext (sLit "cannot eta-reduce the representation type enough")
1002                                 else empty
1003                                 ]
1004 \end{code}
1005
1006
1007 %************************************************************************
1008 %*                                                                      *
1009 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1010 %*                                                                      *
1011 %************************************************************************
1012
1013 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1014 terms, which is the final correct RHS for the corresponding original
1015 equation.
1016 \begin{itemize}
1017 \item
1018 Each (k,TyVarTy tv) in a solution constrains only a type
1019 variable, tv.
1020
1021 \item
1022 The (k,TyVarTy tv) pairs in a solution are canonically
1023 ordered by sorting on type varible, tv, (major key) and then class, k,
1024 (minor key)
1025 \end{itemize}
1026
1027 \begin{code}
1028 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1029
1030 inferInstanceContexts _ [] = return []
1031
1032 inferInstanceContexts oflag infer_specs
1033   = do  { traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
1034         ; iterate_deriv 1 initial_solutions }
1035   where
1036     ------------------------------------------------------------------
1037         -- The initial solutions for the equations claim that each
1038         -- instance has an empty context; this solution is certainly
1039         -- in canonical form.
1040     initial_solutions :: [ThetaType]
1041     initial_solutions = [ [] | _ <- infer_specs ]
1042
1043     ------------------------------------------------------------------
1044         -- iterate_deriv calculates the next batch of solutions,
1045         -- compares it with the current one; finishes if they are the
1046         -- same, otherwise recurses with the new solutions.
1047         -- It fails if any iteration fails
1048     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1049     iterate_deriv n current_solns
1050       | n > 20  -- Looks as if we are in an infinite loop
1051                 -- This can happen if we have -XUndecidableInstances
1052                 -- (See TcSimplify.tcSimplifyDeriv.)
1053       = pprPanic "solveDerivEqns: probable loop"
1054                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1055       | otherwise
1056       = do {      -- Extend the inst info from the explicit instance decls
1057                   -- with the current set of solutions, and simplify each RHS
1058              let inst_specs = zipWithEqual "add_solns" (mkInstance2 oflag)
1059                                            current_solns infer_specs
1060            ; new_solns <- checkNoErrs $
1061                           extendLocalInstEnv inst_specs $
1062                           mapM gen_soln infer_specs
1063
1064            ; if (current_solns == new_solns) then
1065                 return [ spec { ds_theta = soln }
1066                        | (spec, soln) <- zip infer_specs current_solns ]
1067              else
1068                 iterate_deriv (n+1) new_solns }
1069
1070     ------------------------------------------------------------------
1071     gen_soln :: DerivSpec  -> TcM [PredType]
1072     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1073                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1074       = setSrcSpan loc  $
1075         addErrCtxt (derivInstCtxt clas inst_tys) $
1076         do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
1077                 -- checkValidInstance tyvars theta clas inst_tys
1078                 -- Not necessary; see Note [Exotic derived instance contexts]
1079                 --                in TcSimplify
1080
1081                   -- Check for a bizarre corner case, when the derived instance decl should
1082                   -- have form  instance C a b => D (T a) where ...
1083                   -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
1084                   -- of problems; in particular, it's hard to compare solutions for
1085                   -- equality when finding the fixpoint.  So I just rule it out for now.
1086            ; let tv_set = mkVarSet tyvars
1087                  weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]
1088            ; mapM_ (addErrTc . badDerivedPred) weird_preds
1089
1090                 -- Claim: the result instance declaration is guaranteed valid
1091                 -- Hence no need to call:
1092                 --   checkValidInstance tyvars theta clas inst_tys
1093            ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution
1094
1095 ------------------------------------------------------------------
1096 mkInstance1 :: OverlapFlag -> DerivSpec -> Instance
1097 mkInstance1 overlap_flag spec = mkInstance2 overlap_flag (ds_theta spec) spec
1098
1099 mkInstance2 :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1100 mkInstance2 overlap_flag theta
1101             (DS { ds_name = dfun_name
1102                 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1103   = mkLocalInstance dfun overlap_flag
1104   where
1105     dfun = mkDictFunId dfun_name tyvars theta clas tys
1106
1107
1108 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1109 -- Add new locally-defined instances; don't bother to check
1110 -- for functional dependency errors -- that'll happen in TcInstDcls
1111 extendLocalInstEnv dfuns thing_inside
1112  = do { env <- getGblEnv
1113       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1114              env'      = env { tcg_inst_env = inst_env' }
1115       ; setGblEnv env' thing_inside }
1116 \end{code}
1117
1118
1119 %************************************************************************
1120 %*                                                                      *
1121 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1122 %*                                                                      *
1123 %************************************************************************
1124
1125 After all the trouble to figure out the required context for the
1126 derived instance declarations, all that's left is to chug along to
1127 produce them.  They will then be shoved into @tcInstDecls2@, which
1128 will do all its usual business.
1129
1130 There are lots of possibilities for code to generate.  Here are
1131 various general remarks.
1132
1133 PRINCIPLES:
1134 \begin{itemize}
1135 \item
1136 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1137 ``you-couldn't-do-better-by-hand'' efficient.
1138
1139 \item
1140 Deriving @Show@---also pretty common--- should also be reasonable good code.
1141
1142 \item
1143 Deriving for the other classes isn't that common or that big a deal.
1144 \end{itemize}
1145
1146 PRAGMATICS:
1147
1148 \begin{itemize}
1149 \item
1150 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1151
1152 \item
1153 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1154
1155 \item
1156 We {\em normally} generate code only for the non-defaulted methods;
1157 there are some exceptions for @Eq@ and (especially) @Ord@...
1158
1159 \item
1160 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1161 constructor's numeric (@Int#@) tag.  These are generated by
1162 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1163 these is around is given by @hasCon2TagFun@.
1164
1165 The examples under the different sections below will make this
1166 clearer.
1167
1168 \item
1169 Much less often (really just for deriving @Ix@), we use a
1170 @_tag2con_<tycon>@ function.  See the examples.
1171
1172 \item
1173 We use the renamer!!!  Reason: we're supposed to be
1174 producing @LHsBinds Name@ for the methods, but that means
1175 producing correctly-uniquified code on the fly.  This is entirely
1176 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1177 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1178 the renamer.  What a great hack!
1179 \end{itemize}
1180
1181 \begin{code}
1182 -- Generate the InstInfo for the required instance paired with the
1183 --   *representation* tycon for that instance,
1184 -- plus any auxiliary bindings required
1185 --
1186 -- Representation tycons differ from the tycon in the instance signature in
1187 -- case of instances for indexed families.
1188 --
1189 genInst :: OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1190 genInst oflag spec
1191   | ds_newtype spec
1192   = return (InstInfo { iSpec  = mkInstance1 oflag spec
1193                      , iBinds = NewTypeDerived }, [])
1194
1195   | otherwise
1196   = do  { let loc        = getSrcSpan (ds_name spec)
1197               inst       = mkInstance1 oflag spec
1198               clas       = ds_cls spec
1199               rep_tycon  = ds_tc spec
1200
1201           -- In case of a family instance, we need to use the representation
1202           -- tycon (after all, it has the data constructors)
1203         ; fix_env <- getFixityEnv
1204         ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1205
1206         -- Build the InstInfo
1207         ; return (InstInfo { iSpec = inst,
1208                              iBinds = VanillaInst meth_binds [] },
1209                   aux_binds)
1210         }
1211
1212 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1213 genDerivBinds loc fix_env clas tycon
1214   | className clas `elem` typeableClassNames
1215   = (gen_Typeable_binds loc tycon, [])
1216
1217   | otherwise
1218   = case assocMaybe gen_list (getUnique clas) of
1219         Just gen_fn -> gen_fn loc tycon
1220         Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1221   where
1222     gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1223     gen_list = [(eqClassKey,       gen_Eq_binds)
1224                ,(ordClassKey,      gen_Ord_binds)
1225                ,(enumClassKey,     gen_Enum_binds)
1226                ,(boundedClassKey,  gen_Bounded_binds)
1227                ,(ixClassKey,       gen_Ix_binds)
1228                ,(showClassKey,     gen_Show_binds fix_env)
1229                ,(readClassKey,     gen_Read_binds fix_env)
1230                ,(dataClassKey,     gen_Data_binds)
1231                ]
1232 \end{code}
1233
1234
1235 %************************************************************************
1236 %*                                                                      *
1237 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1238 %*                                                                      *
1239 %************************************************************************
1240
1241 \begin{code}
1242 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1243 derivingKindErr tc cls cls_tys cls_kind
1244   = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1245                 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1246        2 (ptext (sLit "Class") <+> quotes (ppr cls)
1247             <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1248
1249 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1250 typeFamilyPapErr tc cls cls_tys inst_ty
1251   = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1252        2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1253
1254 derivingThingErr :: Class -> [Type] -> Type -> Message -> Message
1255 derivingThingErr clas tys ty why
1256   = sep [hsep [ptext (sLit "Can't make a derived instance of"),
1257                quotes (ppr pred)],
1258          nest 2 (parens why)]
1259   where
1260     pred = mkClassPred clas (tys ++ [ty])
1261
1262 derivingHiddenErr :: TyCon -> SDoc
1263 derivingHiddenErr tc
1264   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1265        2 (ptext (sLit "so you cannot derive an instance for it"))
1266
1267 standaloneCtxt :: LHsType Name -> SDoc
1268 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1269                        2 (quotes (ppr ty))
1270
1271 derivInstCtxt :: Class -> [Type] -> Message
1272 derivInstCtxt clas inst_tys
1273   = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1274
1275 badDerivedPred :: PredType -> Message
1276 badDerivedPred pred
1277   = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1278           ptext (sLit "type variables that are not data type parameters"),
1279           nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
1280 \end{code}