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 Coercion
  34 import ErrUtils
  35 import MkId
  36 import DataCon
  37 import Maybes
  38 import RdrName
  39 import Name
  40 import NameSet
  41 import TyCon
  42 import TcType
  43 import Var
  44 import VarSet
  45 import PrelNames
  46 import SrcLoc
  47 import Util
  48 import ListSetOps
  49 import Outputable
  50 import FastString
  51 import Bag
  52
  53 import Control.Monad
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58                 Overview
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 Overall plan
  63 ~~~~~~~~~~~~
  64 1.  Convert the decls (i.e. data/newtype deriving clauses,
  65     plus standalone deriving) to [EarlyDerivSpec]
  66
  67 2.  Infer the missing contexts for the Left DerivSpecs
  68
  69 3.  Add the derived bindings, generating InstInfos
  70
  71
  72 \begin{code}
  73 -- DerivSpec is purely  local to this module
  74 data DerivSpec  = DS { ds_loc     :: SrcSpan
  75                      , ds_orig    :: CtOrigin
  76                      , ds_name    :: Name
  77                      , ds_tvs     :: [TyVar]
  78                      , ds_theta   :: ThetaType
  79                      , ds_cls     :: Class
  80                      , ds_tys     :: [Type]
  81                      , ds_tc      :: TyCon
  82                      , ds_tc_args :: [Type]
  83                      , ds_newtype :: Bool }
  84         -- This spec implies a dfun declaration of the form
  85         --       df :: forall tvs. theta => C tys
  86         -- The Name is the name for the DFun we'll build
  87         -- The tyvars bind all the variables in the theta
  88         -- For type families, the tycon in
  89         --       in ds_tys is the *family* tycon
  90         --       in ds_tc, ds_tc_args is the *representation* tycon
  91         -- For non-family tycons, both are the same
  92
  93         -- ds_newtype = True  <=> Newtype deriving
  94         --              False <=> Vanilla deriving
  95 \end{code}
  96
  97 Example:
  98
  99      newtype instance T [a] = MkT (Tree a) deriving( C s )
 100 ==>
 101      axiom T [a] = :RTList a
 102      axiom :RTList a = Tree a
 103
 104      DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
 105         , ds_tc = :RTList, ds_tc_args = [a]
 106         , ds_newtype = True }
 107
 108 \begin{code}
 109 type DerivContext = Maybe ThetaType
 110    -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
 111    -- Just theta <=> Standalone deriving: context supplied by programmer
 112
 113 type EarlyDerivSpec = Either DerivSpec DerivSpec
 114         -- Left  ds => the context for the instance should be inferred
 115         --             In this case ds_theta is the list of all the
 116         --                constraints needed, such as (Eq [a], Eq a)
 117         --                The inference process is to reduce this to a
 118         --                simpler form (e.g. Eq a)
 119         --
 120         -- Right ds => the exact context for the instance is supplied
 121         --             by the programmer; it is ds_theta
 122
 123 pprDerivSpec :: DerivSpec -> SDoc
 124 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
 125                    ds_cls = c, ds_tys = tys, ds_theta = rhs })
 126   = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
 127             <+> equals <+> ppr rhs)
 128 \end{code}
 129
 130
 131 Inferring missing contexts
 132 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 133 Consider
 134
 135         data T a b = C1 (Foo a) (Bar b)
 136                    | C2 Int (T b a)
 137                    | C3 (T a a)
 138                    deriving (Eq)
 139
 140 [NOTE: See end of these comments for what to do with
 141         data (C a, D b) => T a b = ...
 142 ]
 143
 144 We want to come up with an instance declaration of the form
 145
 146         instance (Ping a, Pong b, ...) => Eq (T a b) where
 147                 x == y = ...
 148
 149 It is pretty easy, albeit tedious, to fill in the code "...".  The
 150 trick is to figure out what the context for the instance decl is,
 151 namely @Ping@, @Pong@ and friends.
 152
 153 Let's call the context reqd for the T instance of class C at types
 154 (a,b, ...)  C (T a b).  Thus:
 155
 156         Eq (T a b) = (Ping a, Pong b, ...)
 157
 158 Now we can get a (recursive) equation from the @data@ decl:
 159
 160         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 161                    u Eq (T b a) u Eq Int        -- From C2
 162                    u Eq (T a a)                 -- From C3
 163
 164 Foo and Bar may have explicit instances for @Eq@, in which case we can
 165 just substitute for them.  Alternatively, either or both may have
 166 their @Eq@ instances given by @deriving@ clauses, in which case they
 167 form part of the system of equations.
 168
 169 Now all we need do is simplify and solve the equations, iterating to
 170 find the least fixpoint.  Notice that the order of the arguments can
 171 switch around, as here in the recursive calls to T.
 172
 173 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 174
 175 We start with:
 176
 177         Eq (T a b) = {}         -- The empty set
 178
 179 Next iteration:
 180         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 181                    u Eq (T b a) u Eq Int        -- From C2
 182                    u Eq (T a a)                 -- From C3
 183
 184         After simplification:
 185                    = Eq a u Ping b u {} u {} u {}
 186                    = Eq a u Ping b
 187
 188 Next iteration:
 189
 190         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 191                    u Eq (T b a) u Eq Int        -- From C2
 192                    u Eq (T a a)                 -- From C3
 193
 194         After simplification:
 195                    = Eq a u Ping b
 196                    u (Eq b u Ping a)
 197                    u (Eq a u Ping a)
 198
 199                    = Eq a u Ping b u Eq b u Ping a
 200
 201 The next iteration gives the same result, so this is the fixpoint.  We
 202 need to make a canonical form of the RHS to ensure convergence.  We do
 203 this by simplifying the RHS to a form in which
 204
 205         - the classes constrain only tyvars
 206         - the list is sorted by tyvar (major key) and then class (minor key)
 207         - no duplicates, of course
 208
 209 So, here are the synonyms for the ``equation'' structures:
 210
 211
 212 Note [Data decl contexts]
 213 ~~~~~~~~~~~~~~~~~~~~~~~~~
 214 Consider
 215
 216         data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
 217
 218 We will need an instance decl like:
 219
 220         instance (Read a, RealFloat a) => Read (Complex a) where
 221           ...
 222
 223 The RealFloat in the context is because the read method for Complex is bound
 224 to construct a Complex, and doing that requires that the argument type is
 225 in RealFloat.
 226
 227 But this ain't true for Show, Eq, Ord, etc, since they don't construct
 228 a Complex; they only take them apart.
 229
 230 Our approach: identify the offending classes, and add the data type
 231 context to the instance decl.  The "offending classes" are
 232
 233         Read, Enum?
 234
 235 FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
 236 pattern matching against a constructor from a data type with a context
 237 gives rise to the constraints for that context -- or at least the thinned
 238 version.  So now all classes are "offending".
 239
 240 Note [Newtype deriving]
 241 ~~~~~~~~~~~~~~~~~~~~~~~
 242 Consider this:
 243     class C a b
 244     instance C [a] Char
 245     newtype T = T Char deriving( C [a] )
 246
 247 Notice the free 'a' in the deriving.  We have to fill this out to
 248     newtype T = T Char deriving( forall a. C [a] )
 249
 250 And then translate it to:
 251     instance C [a] Char => C [a] T where ...
 252
 253
 254 Note [Newtype deriving superclasses]
 255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 256 (See also Trac #1220 for an interesting exchange on newtype
 257 deriving and superclasses.)
 258
 259 The 'tys' here come from the partial application in the deriving
 260 clause. The last arg is the new instance type.
 261
 262 We must pass the superclasses; the newtype might be an instance
 263 of them in a different way than the representation type
 264 E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
 265 Then the Show instance is not done via isomorphism; it shows
 266         Foo 3 as "Foo 3"
 267 The Num instance is derived via isomorphism, but the Show superclass
 268 dictionary must the Show instance for Foo, *not* the Show dictionary
 269 gotten from the Num dictionary. So we must build a whole new dictionary
 270 not just use the Num one.  The instance we want is something like:
 271      instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
 272         (+) = ((+)@a)
 273         ...etc...
 274 There may be a coercion needed which we get from the tycon for the newtype
 275 when the dict is constructed in TcInstDcls.tcInstDecl2
 276
 277
 278 Note [Unused constructors and deriving clauses]
 279 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 280 See Trac #3221.  Consider
 281    data T = T1 | T2 deriving( Show )
 282 Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
 283 both of them.  So we gather defs/uses from deriving just like anything else.
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
 293             -> [LInstDecl Name]  -- All instance declarations
 294             -> [LDerivDecl Name] -- All stand-alone deriving declarations
 295             -> TcM ([InstInfo Name],    -- The generated "instance decls"
 296                     HsValBinds Name,    -- Extra generated top-level bindings
 297                     DefUses)
 298
 299 tcDeriving tycl_decls inst_decls deriv_decls
 300   = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
 301     do  {       -- Fish the "deriving"-related information out of the TcEnv
 302                 -- And make the necessary "equations".
 303           is_boot <- tcIsHsBoot
 304         ; traceTc "tcDeriving" (ppr is_boot)
 305         ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 306
 307         ; overlap_flag <- getOverlapFlag
 308         ; let (infer_specs, given_specs) = splitEithers early_specs
 309         ; insts1 <- mapM (genInst True overlap_flag) given_specs
 310
 311         ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
 312                          inferInstanceContexts overlap_flag infer_specs
 313
 314         ; insts2 <- mapM (genInst False overlap_flag) final_specs
 315
 316                  -- Generate the generic to/from functions from each type declaration
 317         ; gen_binds <- mkGenericBinds is_boot tycl_decls
 318         ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 319
 320         ; dflags <- getDOpts
 321         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
 322                  (ddump_deriving inst_info rn_binds))
 323
 324         ; return (inst_info, rn_binds, rn_dus) }
 325   where
 326     ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
 327     ddump_deriving inst_infos extra_binds
 328       = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
 329
 330 renameDeriv :: Bool -> LHsBinds RdrName
 331             -> [(InstInfo RdrName, DerivAuxBinds)]
 332             -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
 333 renameDeriv is_boot gen_binds insts
 334   | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
 335                 -- The inst-info bindings will all be empty, but it's easier to
 336                 -- just use rn_inst_info to change the type appropriately
 337   = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
 338         ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
 339
 340   | otherwise
 341   = discardWarnings $    -- Discard warnings about unused bindings etc
 342     do  { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $  -- Type signatures in patterns
 343                                                                   -- are used in the generic binds
 344                                rnTopBinds (ValBindsIn gen_binds [])
 345         ; keepAliveSetTc (duDefs dus_gen)       -- Mark these guys to be kept alive
 346
 347                 -- Generate and rename any extra not-one-inst-decl-specific binds,
 348                 -- notably "con2tag" and/or "tag2con" functions.
 349                 -- Bring those names into scope before renaming the instances themselves
 350         ; loc <- getSrcSpanM    -- Generic loc for shared bindings
 351         ; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $
 352                                       rm_dups [] $ concat deriv_aux_binds
 353               aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
 354         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
 355         ; bindLocalNames (collectHsValBinders rn_aux_lhs) $
 356     do  { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
 357         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
 358         ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
 359                   dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
 360
 361   where
 362     (inst_infos, deriv_aux_binds) = unzip insts
 363
 364         -- Remove duplicate requests for auxilliary bindings
 365     rm_dups acc [] = acc
 366     rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
 367                        | otherwise            = rm_dups (b:acc) bs
 368
 369
 370     rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
 371     rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
 372         = return ( info { iBinds = NewTypeDerived coi tc }
 373                  , mkFVs (map dataConName (tyConDataCons tc)))
 374           -- See Note [Newtype deriving and unused constructors]
 375
 376     rn_inst_info (InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
 377         =       -- Bring the right type variables into
 378                 -- scope (yuk), and rename the method binds
 379            ASSERT( null sigs )
 380            bindLocalNames (map Var.varName tyvars) $
 381            do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
 382               ; let binds' = VanillaInst rn_binds [] standalone_deriv
 383               ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) }
 384         where
 385           (tyvars,_, clas,_) = instanceHead inst
 386           clas_nm            = className clas
 387
 388 -----------------------------------------
 389 mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
 390 mkGenericBinds is_boot tycl_decls
 391   | is_boot
 392   = return emptyBag
 393   | otherwise
 394   = do  { tcs <- mapM tcLookupTyCon [ tcdName d
 395                                     | L _ d <- tycl_decls, isDataDecl d ]
 396         ; return (unionManyBags [ mkTyConGenericBinds tc
 397                                 | tc <- tcs, tyConHasGenerics tc ]) }
 398                 -- We are only interested in the data type declarations,
 399                 -- and then only in the ones whose 'has-generics' flag is on
 400                 -- The predicate tyConHasGenerics finds both of these
 401 \end{code}
 402
 403 Note [Newtype deriving and unused constructors]
 404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 405 Consider this (see Trac #1954):
 406
 407   module Bug(P) where
 408   newtype P a = MkP (IO a) deriving Monad
 409
 410 If you compile with -fwarn-unused-binds you do not expect the warning
 411 "Defined but not used: data consructor MkP". Yet the newtype deriving
 412 code does not explicitly mention MkP, but it should behave as if you
 413 had written
 414   instance Monad P where
 415      return x = MkP (return x)
 416      ...etc...
 417
 418 So we want to signal a user of the data constructor 'MkP'.  That's
 419 what we do in rn_inst_info, and it's the only reason we have the TyCon
 420 stored in NewTypeDerived.
 421
 422
 423 %************************************************************************
 424 %*                                                                      *
 425                 From HsSyn to DerivSpec
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
 430
 431 \begin{code}
 432 makeDerivSpecs :: Bool
 433                -> [LTyClDecl Name]
 434                -> [LInstDecl Name]
 435                -> [LDerivDecl Name]
 436                -> TcM [EarlyDerivSpec]
 437
 438 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 439   | is_boot     -- No 'deriving' at all in hs-boot files
 440   = do  { mapM_ add_deriv_err deriv_locs
 441         ; return [] }
 442   | otherwise
 443   = do  { eqns1 <- mapAndRecoverM deriveTyData all_tydata
 444         ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
 445         ; return (eqns1 ++ eqns2) }
 446   where
 447     extractTyDataPreds decls
 448       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
 449
 450     all_tydata :: [(LHsType Name, LTyClDecl Name)]
 451         -- Derived predicate paired with its data type declaration
 452     all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
 453
 454     deriv_locs = map (getLoc . snd) all_tydata
 455                  ++ map getLoc deriv_decls
 456
 457     add_deriv_err loc = setSrcSpan loc $
 458                         addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
 459                                    2 (ptext (sLit "Use an instance declaration instead")))
 460
 461 ------------------------------------------------------------------
 462 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
 463 -- Standalone deriving declarations
 464 --  e.g.   deriving instance Show a => Show (T a)
 465 -- Rather like tcLocalInstDecl
 466 deriveStandalone (L loc (DerivDecl deriv_ty))
 467   = setSrcSpan loc                   $
 468     addErrCtxt (standaloneCtxt deriv_ty)  $
 469     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
 470        ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
 471        ; traceTc "Standalone deriving;" $ vcat
 472               [ text "tvs:" <+> ppr tvs
 473               , text "theta:" <+> ppr theta
 474               , text "tau:" <+> ppr tau ]
 475        ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau
 476                 -- C.f. TcInstDcls.tcLocalInstDecl1
 477
 478        ; let cls_tys = take (length inst_tys - 1) inst_tys
 479              inst_ty = last inst_tys
 480        ; traceTc "Standalone deriving:" $ vcat
 481               [ text "class:" <+> ppr cls
 482               , text "class types:" <+> ppr cls_tys
 483               , text "type:" <+> ppr inst_ty ]
 484        ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
 485                    (Just theta) }
 486
 487 ------------------------------------------------------------------
 488 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
 489 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
 490                                                    tcdTyVars = tv_names,
 491                                                    tcdTyPats = ty_pats }))
 492   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
 493     tcAddDeclCtxt decl $
 494     do  { (tvs, tc, tc_args) <- get_lhs ty_pats
 495         ; tcExtendTyVarEnv tvs $        -- Deriving preds may (now) mention
 496                                         -- the type variables for the type constructor
 497
 498     do  { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
 499                 -- The "deriv_pred" is a LHsType to take account of the fact that for
 500                 -- newtype deriving we allow deriving (forall a. C [a]).
 501
 502         -- Given data T a b c = ... deriving( C d ),
 503         -- we want to drop type variables from T so that (C d (T a)) is well-kinded
 504         ; let cls_tyvars = classTyVars cls
 505               kind = tyVarKind (last cls_tyvars)
 506               (arg_kinds, _) = splitKindFunTys kind
 507               n_args_to_drop = length arg_kinds
 508               n_args_to_keep = tyConArity tc - n_args_to_drop
 509               args_to_drop   = drop n_args_to_keep tc_args
 510               inst_ty        = mkTyConApp tc (take n_args_to_keep tc_args)
 511               inst_ty_kind   = typeKind inst_ty
 512               dropped_tvs    = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
 513               univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
 514                                         `minusVarSet` dropped_tvs
 515
 516         -- Check that the result really is well-kinded
 517         ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
 518                   (derivingKindErr tc cls cls_tys kind)
 519
 520         ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop &&           -- (a)
 521                    tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
 522                   (derivingEtaErr cls cls_tys inst_ty)
 523                 -- Check that
 524                 --  (a) The data type can be eta-reduced; eg reject:
 525                 --              data instance T a a = ... deriving( Monad )
 526                 --  (b) The type class args do not mention any of the dropped type
 527                 --      variables
 528                 --              newtype T a s = ... deriving( ST s )
 529
 530         -- Type families can't be partially applied
 531         -- e.g.   newtype instance T Int a = MkT [a] deriving( Monad )
 532         -- Note [Deriving, type families, and partial applications]
 533         ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
 534                   (typeFamilyPapErr tc cls cls_tys inst_ty)
 535
 536         ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
 537   where
 538         -- Tiresomely we must figure out the "lhs", which is awkward for type families
 539         -- E.g.   data T a b = .. deriving( Eq )
 540         --          Here, the lhs is (T a b)
 541         --        data instance TF Int b = ... deriving( Eq )
 542         --          Here, the lhs is (TF Int b)
 543         -- But if we just look up the tycon_name, we get is the *family*
 544         -- tycon, but not pattern types -- they are in the *rep* tycon.
 545     get_lhs Nothing     = do { tc <- tcLookupTyCon tycon_name
 546                              ; let tvs = tyConTyVars tc
 547                              ; return (tvs, tc, mkTyVarTys tvs) }
 548     get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
 549                              ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
 550                              ; let (tc, tc_args) = tcSplitTyConApp tc_app
 551                              ; return (tvs, tc, tc_args) }
 552
 553 deriveTyData _other
 554   = panic "derivTyData" -- Caller ensures that only TyData can happen
 555 \end{code}
 556
 557 Note [Deriving, type families, and partial applications]
 558 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 559 When there are no type families, it's quite easy:
 560
 561     newtype S a = MkS [a]
 562     -- :CoS :: S  ~ []  -- Eta-reduced
 563
 564     instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
 565     instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
 566
 567 When type familes are involved it's trickier:
 568
 569     data family T a b
 570     newtype instance T Int a = MkT [a] deriving( Eq, Monad )
 571     -- :RT is the representation type for (T Int a)
 572     --  :CoF:R1T a :: T Int a ~ :RT a   -- Not eta reduced
 573     --  :Co:R1T    :: :RT ~ []          -- Eta-reduced
 574
 575     instance Eq [a] => Eq (T Int a)     -- easy by coercion
 576     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
 577
 578 The "???" bit is that we don't build the :CoF thing in eta-reduced form
 579 Henc the current typeFamilyPapErr, even though the instance makes sense.
 580 After all, we can write it out
 581     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
 582       return x = MkT [x]
 583       ... etc ...
 584
 585 \begin{code}
 586 mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
 587           -> DerivContext       -- Just    => context supplied (standalone deriving)
 588                                 -- Nothing => context inferred (deriving on data decl)
 589           -> TcRn EarlyDerivSpec
 590 -- Make the EarlyDerivSpec for an instance
 591 --      forall tvs. theta => cls (tys ++ [ty])
 592 -- where the 'theta' is optional (that's the Maybe part)
 593 -- Assumes that this declaration is well-kinded
 594
 595 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
 596   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
 597   , isAlgTyCon tycon    -- Check for functions, primitive types etc
 598   = do  { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
 599                   -- Be careful to test rep_tc here: in the case of families,
 600                   -- we want to check the instance tycon, not the family tycon
 601
 602         -- For standalone deriving (mtheta /= Nothing),
 603         -- check that all the data constructors are in scope.
 604         -- No need for this when deriving Typeable, becuase we don't need
 605         -- the constructors for that.
 606         ; rdr_env <- getGlobalRdrEnv
 607         ; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc)
 608               not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
 609         ; checkTc (isNothing mtheta ||
 610                    not hidden_data_cons ||
 611                    className cls `elem` typeableClassNames)
 612                   (derivingHiddenErr tycon)
 613
 614         ; dflags <- getDOpts
 615         ; if isDataTyCon rep_tc then
 616                 mkDataTypeEqn orig dflags tvs cls cls_tys
 617                               tycon tc_args rep_tc rep_tc_args mtheta
 618           else
 619                 mkNewTypeEqn orig dflags tvs cls cls_tys
 620                              tycon tc_args rep_tc rep_tc_args mtheta }
 621   | otherwise
 622   = failWithTc (derivingThingErr False cls cls_tys tc_app
 623                (ptext (sLit "The last argument of the instance must be a data or newtype application")))
 624 \end{code}
 625
 626
 627 %************************************************************************
 628 %*                                                                      *
 629                 Deriving data types
 630 %*                                                                      *
 631 %************************************************************************
 632
 633 \begin{code}
 634 mkDataTypeEqn :: CtOrigin
 635               -> DynFlags
 636               -> [Var]                  -- Universally quantified type variables in the instance
 637               -> Class                  -- Class for which we need to derive an instance
 638               -> [Type]                 -- Other parameters to the class except the last
 639               -> TyCon                  -- Type constructor for which the instance is requested
 640                                         --    (last parameter to the type class)
 641               -> [Type]                 -- Parameters to the type constructor
 642               -> TyCon                  -- rep of the above (for type families)
 643               -> [Type]                 -- rep of the above
 644               -> DerivContext        -- Context of the instance, for standalone deriving
 645               -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error
 646
 647 mkDataTypeEqn orig dflags tvs cls cls_tys
 648               tycon tc_args rep_tc rep_tc_args mtheta
 649   = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
 650         -- NB: pass the *representation* tycon to checkSideConditions
 651         CanDerive               -> go_for_it
 652         NonDerivableClass       -> bale_out (nonStdErr cls)
 653         DerivableClassError msg -> bale_out msg
 654   where
 655     go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 656     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
 657
 658 mk_data_eqn, mk_typeable_eqn
 659    :: CtOrigin -> [TyVar] -> Class
 660    -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
 661    -> TcM EarlyDerivSpec
 662 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 663   | getName cls `elem` typeableClassNames
 664   = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 665
 666   | otherwise
 667   = do  { dfun_name <- new_dfun_name cls tycon
 668         ; loc <- getSrcSpanM
 669         ; let inst_tys = [mkTyConApp tycon tc_args]
 670               inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
 671               spec = DS { ds_loc = loc, ds_orig = orig
 672                         , ds_name = dfun_name, ds_tvs = tvs
 673                         , ds_cls = cls, ds_tys = inst_tys
 674                         , ds_tc = rep_tc, ds_tc_args = rep_tc_args
 675                         , ds_theta =  mtheta `orElse` inferred_constraints
 676                         , ds_newtype = False }
 677
 678         ; return (if isJust mtheta then Right spec      -- Specified context
 679                                    else Left spec) }    -- Infer context
 680
 681 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 682         -- The Typeable class is special in several ways
 683         --        data T a b = ... deriving( Typeable )
 684         -- gives
 685         --        instance Typeable2 T where ...
 686         -- Notice that:
 687         -- 1. There are no constraints in the instance
 688         -- 2. There are no type variables either
 689         -- 3. The actual class we want to generate isn't necessarily
 690         --      Typeable; it depends on the arity of the type
 691   | isNothing mtheta    -- deriving on a data type decl
 692   = do  { checkTc (cls `hasKey` typeableClassKey)
 693                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
 694         ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
 695         ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) }
 696
 697   | otherwise           -- standaone deriving
 698   = do  { checkTc (null tc_args)
 699                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
 700                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
 701         ; dfun_name <- new_dfun_name cls tycon
 702         ; loc <- getSrcSpanM
 703         ; return (Right $
 704                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
 705                      , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
 706                      , ds_tc = rep_tc, ds_tc_args = rep_tc_args
 707                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
 708
 709
 710 inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
 711 -- Generate a sufficiently large set of constraints that typechecking the
 712 -- generated method definitions should succeed.   This set will be simplified
 713 -- before being used in the instance declaration
 714 inferConstraints _ cls inst_tys rep_tc rep_tc_args
 715   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
 716     stupid_constraints ++ extra_constraints
 717     ++ sc_constraints ++ con_arg_constraints
 718   where
 719        -- Constraints arising from the arguments of each constructor
 720     con_arg_constraints
 721       = [ mkClassPred cls [arg_ty]
 722         | data_con <- tyConDataCons rep_tc,
 723           arg_ty   <- ASSERT( isVanillaDataCon data_con )
 724                         get_constrained_tys $
 725                         dataConInstOrigArgTys data_con all_rep_tc_args,
 726           not (isUnLiftedType arg_ty) ]
 727                 -- No constraints for unlifted types
 728                 -- Where they are legal we generate specilised function calls
 729
 730                 -- For functor-like classes, two things are different
 731                 -- (a) We recurse over argument types to generate constraints
 732                 --     See Functor examples in TcGenDeriv
 733                 -- (b) The rep_tc_args will be one short
 734     is_functor_like = getUnique cls `elem` functorLikeClassKeys
 735
 736     get_constrained_tys :: [Type] -> [Type]
 737     get_constrained_tys tys
 738         | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
 739         | otherwise       = tys
 740
 741     rep_tc_tvs = tyConTyVars rep_tc
 742     last_tv = last rep_tc_tvs
 743     all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
 744                     | otherwise       = rep_tc_args
 745
 746         -- Constraints arising from superclasses
 747         -- See Note [Superclasses of derived instance]
 748     sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
 749                                 (classSCTheta cls)
 750
 751         -- Stupid constraints
 752     stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
 753     subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
 754
 755         -- Extra Data constraints
 756         -- The Data class (only) requires that for
 757         --    instance (...) => Data (T t1 t2)
 758         -- IF   t1:*, t2:*
 759         -- THEN (Data t1, Data t2) are among the (...) constraints
 760         -- Reason: when the IF holds, we generate a method
 761         --             dataCast2 f = gcast2 f
 762         --         and we need the Data constraints to typecheck the method
 763     extra_constraints
 764       | cls `hasKey` dataClassKey
 765       , all (isLiftedTypeKind . typeKind) rep_tc_args
 766       = [mkClassPred cls [ty] | ty <- rep_tc_args]
 767       | otherwise
 768       = []
 769
 770 ------------------------------------------------------------------
 771 -- Check side conditions that dis-allow derivability for particular classes
 772 -- This is *apart* from the newtype-deriving mechanism
 773 --
 774 -- Here we get the representation tycon in case of family instances as it has
 775 -- the data constructors - but we need to be careful to fall back to the
 776 -- family tycon (with indexes) in error messages.
 777
 778 data DerivStatus = CanDerive
 779                  | DerivableClassError SDoc     -- Standard class, but can't do it
 780                  | NonDerivableClass            -- Non-standard class
 781
 782 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus
 783 checkSideConditions dflags mtheta cls cls_tys rep_tc
 784   | Just cond <- sideConditions mtheta cls
 785   = case (cond (dflags, rep_tc)) of
 786         Just err -> DerivableClassError err     -- Class-specific error
 787         Nothing  | null cls_tys -> CanDerive    -- All derivable classes are unary, so
 788                                                 -- cls_tys (the type args other than last)
 789                                                 -- should be null
 790                  | otherwise    -> DerivableClassError ty_args_why      -- e.g. deriving( Eq s )
 791   | otherwise = NonDerivableClass       -- Not a standard class
 792   where
 793     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
 794
 795 nonStdErr :: Class -> SDoc
 796 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
 797
 798 sideConditions :: DerivContext -> Class -> Maybe Condition
 799 sideConditions mtheta cls
 800   | cls_key == eqClassKey          = Just cond_std
 801   | cls_key == ordClassKey         = Just cond_std
 802   | cls_key == showClassKey        = Just cond_std
 803   | cls_key == readClassKey        = Just (cond_std `andCond` cond_noUnliftedArgs)
 804   | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
 805   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct)
 806   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct)
 807   | cls_key == dataClassKey        = Just (checkFlag Opt_DeriveDataTypeable `andCond`
 808                                            cond_std `andCond` cond_noUnliftedArgs)
 809   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
 810                                            cond_functorOK True)  -- NB: no cond_std!
 811   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
 812                                            cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
 813   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
 814                                            cond_functorOK False)
 815   | getName cls `elem` typeableClassNames = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK)
 816   | otherwise = Nothing
 817   where
 818     cls_key = getUnique cls
 819     cond_std = cond_stdOK mtheta
 820
 821 type Condition = (DynFlags, TyCon) -> Maybe SDoc
 822         -- first Bool is whether or not we are allowed to derive Data and Typeable
 823         -- second Bool is whether or not we are allowed to derive Functor
 824         -- TyCon is the *representation* tycon if the
 825         --      data type is an indexed one
 826         -- Nothing => OK
 827
 828 orCond :: Condition -> Condition -> Condition
 829 orCond c1 c2 tc
 830   = case c1 tc of
 831         Nothing -> Nothing          -- c1 succeeds
 832         Just x  -> case c2 tc of    -- c1 fails
 833                      Nothing -> Nothing
 834                      Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
 835                                     -- Both fail
 836
 837 andCond :: Condition -> Condition -> Condition
 838 andCond c1 c2 tc = case c1 tc of
 839                      Nothing -> c2 tc   -- c1 succeeds
 840                      Just x  -> Just x  -- c1 fails
 841
 842 cond_stdOK :: DerivContext -> Condition
 843 cond_stdOK (Just _) _
 844   = Nothing     -- Don't check these conservative conditions for
 845                 -- standalone deriving; just generate the code
 846                 -- and let the typechecker handle the result
 847 cond_stdOK Nothing (_, rep_tc)
 848   | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
 849   | not (null con_whys) = Just (vcat con_whys $$ suggestion)
 850   | otherwise           = Nothing
 851   where
 852     suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
 853     data_cons   = tyConDataCons rep_tc
 854     con_whys = mapCatMaybes check_con data_cons
 855
 856     check_con :: DataCon -> Maybe SDoc
 857     check_con con
 858       | isVanillaDataCon con
 859       , all isTauTy (dataConOrigArgTys con) = Nothing
 860       | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
 861
 862 no_cons_why :: TyCon -> SDoc
 863 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
 864                      ptext (sLit "has no data constructors")
 865
 866 cond_enumOrProduct :: Condition
 867 cond_enumOrProduct = cond_isEnumeration `orCond`
 868                        (cond_isProduct `andCond` cond_noUnliftedArgs)
 869
 870 cond_noUnliftedArgs :: Condition
 871 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 872 -- by generating specilaised code.  For others (eg Data) we don't.
 873 cond_noUnliftedArgs (_, tc)
 874   | null bad_cons = Nothing
 875   | otherwise     = Just why
 876   where
 877     bad_cons = [ con | con <- tyConDataCons tc
 878                      , any isUnLiftedType (dataConOrigArgTys con) ]
 879     why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
 880
 881 cond_isEnumeration :: Condition
 882 cond_isEnumeration (_, rep_tc)
 883   | isEnumerationTyCon rep_tc   = Nothing
 884   | otherwise                   = Just why
 885   where
 886     why = sep [ quotes (pprSourceTyCon rep_tc) <+>
 887                   ptext (sLit "is not an enumeration type")
 888               , nest 2 $ ptext (sLit "(an enumeration consists of one or more nullary constructors)") ]
 889                   -- See Note [Enumeration types] in TyCon
 890
 891 cond_isProduct :: Condition
 892 cond_isProduct (_, rep_tc)
 893   | isProductTyCon rep_tc = Nothing
 894   | otherwise             = Just why
 895   where
 896     why = quotes (pprSourceTyCon rep_tc) <+>
 897           ptext (sLit "does not have precisely one constructor")
 898
 899 cond_typeableOK :: Condition
 900 -- OK for Typeable class
 901 -- Currently: (a) args all of kind *
 902 --            (b) 7 or fewer args
 903 cond_typeableOK (_, rep_tc)
 904   | tyConArity rep_tc > 7       = Just too_many
 905   | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc))
 906                                 = Just bad_kind
 907   | isFamInstTyCon rep_tc       = Just fam_inst  -- no Typable for family insts
 908   | otherwise                   = Nothing
 909   where
 910     too_many = quotes (pprSourceTyCon rep_tc) <+>
 911                ptext (sLit "has too many arguments")
 912     bad_kind = quotes (pprSourceTyCon rep_tc) <+>
 913                ptext (sLit "has arguments of kind other than `*'")
 914     fam_inst = quotes (pprSourceTyCon rep_tc) <+>
 915                ptext (sLit "is a type family")
 916
 917
 918 functorLikeClassKeys :: [Unique]
 919 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
 920
 921 cond_functorOK :: Bool -> Condition
 922 -- OK for Functor/Foldable/Traversable class
 923 -- Currently: (a) at least one argument
 924 --            (b) don't use argument contravariantly
 925 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 926 --            (d) optionally: don't use function types
 927 --            (e) no "stupid context" on data type
 928 cond_functorOK allowFunctions (dflags, rep_tc)
 929   | not (xopt Opt_DeriveFunctor dflags)
 930   = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
 931
 932   | null tc_tvs
 933   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
 934           <+> ptext (sLit "has no parameters"))
 935
 936   | not (null bad_stupid_theta)
 937   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
 938           <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
 939
 940   | otherwise
 941   = msum (map check_con data_cons)      -- msum picks the first 'Just', if any
 942   where
 943     tc_tvs            = tyConTyVars rep_tc
 944     Just (_, last_tv) = snocView tc_tvs
 945     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
 946     is_bad pred       = last_tv `elemVarSet` tyVarsOfPred pred
 947
 948     data_cons = tyConDataCons rep_tc
 949     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
 950
 951     check_vanilla :: DataCon -> Maybe SDoc
 952     check_vanilla con | isVanillaDataCon con = Nothing
 953                       | otherwise            = Just (badCon con existential)
 954
 955     ft_check :: DataCon -> FFoldType (Maybe SDoc)
 956     ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
 957                       , ft_co_var = Just (badCon con covariant)
 958                       , ft_fun = \x y -> if allowFunctions then x `mplus` y
 959                                                            else Just (badCon con functions)
 960                       , ft_tup = \_ xs  -> msum xs
 961                       , ft_ty_app = \_ x   -> x
 962                       , ft_bad_app = Just (badCon con wrong_arg)
 963                       , ft_forall = \_ x   -> x }
 964
 965     existential = ptext (sLit "has existential arguments")
 966     covariant   = ptext (sLit "uses the type variable in a function argument")
 967     functions   = ptext (sLit "contains function types")
 968     wrong_arg   = ptext (sLit "uses the type variable in an argument other than the last")
 969
 970 checkFlag :: ExtensionFlag -> Condition
 971 checkFlag flag (dflags, _)
 972   | xopt flag dflags = Nothing
 973   | otherwise        = Just why
 974   where
 975     why = ptext (sLit "You need -X") <> text flag_str
 976           <+> ptext (sLit "to derive an instance for this class")
 977     flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
 978                  [s]   -> s
 979                  other -> pprPanic "checkFlag" (ppr other)
 980
 981 std_class_via_iso :: Class -> Bool
 982 -- These standard classes can be derived for a newtype
 983 -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
 984 -- because giving so gives the same results as generating the boilerplate
 985 std_class_via_iso clas
 986   = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
 987         -- Not Read/Show because they respect the type
 988         -- Not Enum, because newtypes are never in Enum
 989
 990
 991 non_iso_class :: Class -> Bool
 992 -- *Never* derive Read,Show,Typeable,Data by isomorphism,
 993 -- even with -XGeneralizedNewtypeDeriving
 994 non_iso_class cls
 995   = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
 996                          typeableClassKeys)
 997
 998 typeableClassKeys :: [Unique]
 999 typeableClassKeys = map getUnique typeableClassNames
1000
1001 new_dfun_name :: Class -> TyCon -> TcM Name
1002 new_dfun_name clas tycon        -- Just a simple wrapper
1003   = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
1004         ; newDFunName clas [mkTyConApp tycon []] loc }
1005         -- The type passed to newDFunName is only used to generate
1006         -- a suitable string; hence the empty type arg list
1007
1008 badCon :: DataCon -> SDoc -> SDoc
1009 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1010 \end{code}
1011
1012 Note [Superclasses of derived instance]
1013 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1014 In general, a derived instance decl needs the superclasses of the derived
1015 class too.  So if we have
1016         data T a = ...deriving( Ord )
1017 then the initial context for Ord (T a) should include Eq (T a).  Often this is
1018 redundant; we'll also generate an Ord constraint for each constructor argument,
1019 and that will probably generate enough constraints to make the Eq (T a) constraint
1020 be satisfied too.  But not always; consider:
1021
1022  data S a = S
1023  instance Eq (S a)
1024  instance Ord (S a)
1025
1026  data T a = MkT (S a) deriving( Ord )
1027  instance Num a => Eq (T a)
1028
1029 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1030 Similarly consider:
1031         data T a = MkT deriving( Data, Typeable )
1032 Here there *is* no argument field, but we must nevertheless generate
1033 a context for the Data instances:
1034         instance Typable a => Data (T a) where ...
1035
1036
1037 %************************************************************************
1038 %*                                                                      *
1039                 Deriving newtypes
1040 %*                                                                      *
1041 %************************************************************************
1042
1043 \begin{code}
1044 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1045              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1046              -> DerivContext
1047              -> TcRn EarlyDerivSpec
1048 mkNewTypeEqn orig dflags tvs
1049              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1050 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1051   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1052   = do  { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1053         ; dfun_name <- new_dfun_name cls tycon
1054         ; loc <- getSrcSpanM
1055         ; let spec = DS { ds_loc = loc, ds_orig = orig
1056                         , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
1057                         , ds_cls = cls, ds_tys = inst_tys
1058                         , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1059                         , ds_theta =  mtheta `orElse` all_preds
1060                         , ds_newtype = True }
1061         ; return (if isJust mtheta then Right spec
1062                                    else Left spec) }
1063
1064   | otherwise
1065   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1066       CanDerive -> go_for_it    -- Use the standard H98 method
1067       DerivableClassError msg   -- Error with standard class
1068         | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
1069         | otherwise                  -> bale_out msg
1070       NonDerivableClass         -- Must use newtype deriving
1071         | newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
1072         | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1073         | otherwise                  -> bale_out non_std
1074   where
1075         newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1076         go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1077         bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1078
1079         non_std    = nonStdErr cls
1080         suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1081
1082         -- Here is the plan for newtype derivings.  We see
1083         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1084         -- where t is a type,
1085         --       ak+1...an is a suffix of a1..an, and are all tyars
1086         --       ak+1...an do not occur free in t, nor in the s1..sm
1087         --       (C s1 ... sm) is a  *partial applications* of class C
1088         --                      with the last parameter missing
1089         --       (T a1 .. ak) matches the kind of C's last argument
1090         --              (and hence so does t)
1091         -- The latter kind-check has been done by deriveTyData already,
1092         -- and tc_args are already trimmed
1093         --
1094         -- We generate the instance
1095         --       instance forall ({a1..ak} u fvs(s1..sm)).
1096         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
1097         -- where T a1...ap is the partial application of
1098         --       the LHS of the correct kind and p >= k
1099         --
1100         --      NB: the variables below are:
1101         --              tc_tvs = [a1, ..., an]
1102         --              tyvars_to_keep = [a1, ..., ak]
1103         --              rep_ty = t ak .. an
1104         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
1105         --              tys = [s1, ..., sm]
1106         --              rep_fn' = t
1107         --
1108         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1109         -- We generate the instance
1110         --      instance Monad (ST s) => Monad (T s) where
1111
1112         nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1113                 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1114                 -- eta-reduces the representation type, so we know that
1115                 --      T a ~ S a a
1116                 -- That's convenient here, because we may have to apply
1117                 -- it to fewer than its original complement of arguments
1118
1119         -- Note [Newtype representation]
1120         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1121         -- Need newTyConRhs (*not* a recursive representation finder)
1122         -- to get the representation type. For example
1123         --      newtype B = MkB Int
1124         --      newtype A = MkA B deriving( Num )
1125         -- We want the Num instance of B, *not* the Num instance of Int,
1126         -- when making the Num instance of A!
1127         rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1128         rep_tys     = cls_tys ++ [rep_inst_ty]
1129         rep_pred    = mkClassPred cls rep_tys
1130                 -- rep_pred is the representation dictionary, from where
1131                 -- we are gong to get all the methods for the newtype
1132                 -- dictionary
1133
1134
1135     -- Next we figure out what superclass dictionaries to use
1136     -- See Note [Newtype deriving superclasses] above
1137
1138         cls_tyvars = classTyVars cls
1139         dfun_tvs = tyVarsOfTypes inst_tys
1140         inst_ty = mkTyConApp tycon tc_args
1141         inst_tys = cls_tys ++ [inst_ty]
1142         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1143                               (classSCTheta cls)
1144
1145                 -- If there are no tyvars, there's no need
1146                 -- to abstract over the dictionaries we need
1147                 -- Example:     newtype T = MkT Int deriving( C )
1148                 -- We get the derived instance
1149                 --              instance C T
1150                 -- rather than
1151                 --              instance C Int => C T
1152         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
1153
1154         -------------------------------------------------------------------
1155         --  Figuring out whether we can only do this newtype-deriving thing
1156
1157         can_derive_via_isomorphism
1158            =  not (non_iso_class cls)
1159            && arity_ok
1160            && eta_ok
1161            && ats_ok
1162 --         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
1163
1164         arity_ok = length cls_tys + 1 == classArity cls
1165                 -- Well kinded; eg not: newtype T ... deriving( ST )
1166                 --                      because ST needs *2* type params
1167
1168         -- Check that eta reduction is OK
1169         eta_ok = nt_eta_arity <= length rep_tc_args
1170                 -- The newtype can be eta-reduced to match the number
1171                 --     of type argument actually supplied
1172                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
1173                 --     Here the 'b' must be the same in the rep type (S [a] b)
1174                 --     And the [a] must not mention 'b'.  That's all handled
1175                 --     by nt_eta_rity.
1176
1177         ats_ok = null (classATs cls)
1178                -- No associated types for the class, because we don't
1179                -- currently generate type 'instance' decls; and cannot do
1180                -- so for 'data' instance decls
1181
1182         cant_derive_err
1183            = vcat [ ppUnless arity_ok arity_msg
1184                   , ppUnless eta_ok eta_msg
1185                   , ppUnless ats_ok ats_msg ]
1186         arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1187         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
1188         ats_msg   = ptext (sLit "the class has associated types")
1189 \end{code}
1190
1191 Note [Recursive newtypes]
1192 ~~~~~~~~~~~~~~~~~~~~~~~~~
1193 Newtype deriving works fine, even if the newtype is recursive.
1194 e.g.    newtype S1 = S1 [T1 ()]
1195         newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1196 Remember, too, that type families are curretly (conservatively) given
1197 a recursive flag, so this also allows newtype deriving to work
1198 for type famillies.
1199
1200 We used to exclude recursive types, because we had a rather simple
1201 minded way of generating the instance decl:
1202    newtype A = MkA [A]
1203    instance Eq [A] => Eq A      -- Makes typechecker loop!
1204 But now we require a simple context, so it's ok.
1205
1206
1207 %************************************************************************
1208 %*                                                                      *
1209 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1210 %*                                                                      *
1211 %************************************************************************
1212
1213 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1214 terms, which is the final correct RHS for the corresponding original
1215 equation.
1216 \begin{itemize}
1217 \item
1218 Each (k,TyVarTy tv) in a solution constrains only a type
1219 variable, tv.
1220
1221 \item
1222 The (k,TyVarTy tv) pairs in a solution are canonically
1223 ordered by sorting on type varible, tv, (major key) and then class, k,
1224 (minor key)
1225 \end{itemize}
1226
1227 \begin{code}
1228 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1229
1230 inferInstanceContexts _ [] = return []
1231
1232 inferInstanceContexts oflag infer_specs
1233   = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1234         ; iterate_deriv 1 initial_solutions }
1235   where
1236     ------------------------------------------------------------------
1237         -- The initial solutions for the equations claim that each
1238         -- instance has an empty context; this solution is certainly
1239         -- in canonical form.
1240     initial_solutions :: [ThetaType]
1241     initial_solutions = [ [] | _ <- infer_specs ]
1242
1243     ------------------------------------------------------------------
1244         -- iterate_deriv calculates the next batch of solutions,
1245         -- compares it with the current one; finishes if they are the
1246         -- same, otherwise recurses with the new solutions.
1247         -- It fails if any iteration fails
1248     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1249     iterate_deriv n current_solns
1250       | n > 20  -- Looks as if we are in an infinite loop
1251                 -- This can happen if we have -XUndecidableInstances
1252                 -- (See TcSimplify.tcSimplifyDeriv.)
1253       = pprPanic "solveDerivEqns: probable loop"
1254                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1255       | otherwise
1256       = do {      -- Extend the inst info from the explicit instance decls
1257                   -- with the current set of solutions, and simplify each RHS
1258              let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1259                                            current_solns infer_specs
1260            ; new_solns <- checkNoErrs $
1261                           extendLocalInstEnv inst_specs $
1262                           mapM gen_soln infer_specs
1263
1264            ; if (current_solns == new_solns) then
1265                 return [ spec { ds_theta = soln }
1266                        | (spec, soln) <- zip infer_specs current_solns ]
1267              else
1268                 iterate_deriv (n+1) new_solns }
1269
1270     ------------------------------------------------------------------
1271     gen_soln :: DerivSpec  -> TcM [PredType]
1272     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1273                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1274       = setSrcSpan loc  $
1275         addErrCtxt (derivInstCtxt clas inst_tys) $
1276         do {      -- Check for a bizarre corner case, when the derived instance decl should
1277                   -- have form  instance C a b => D (T a) where ...
1278                   -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
1279                   -- of problems; in particular, it's hard to compare solutions for
1280                   -- equality when finding the fixpoint.  Moreover, simplifyDeriv
1281                   -- has an assert failure because it finds a TyVar when it expects
1282                   -- only TcTyVars.  So I just rule it out for now.  I'm not
1283                   -- even sure how it can arise.
1284
1285            ; let tv_set = mkVarSet tyvars
1286                  weird_preds = [pred | pred <- deriv_rhs
1287                                      , not (tyVarsOfPred pred `subVarSet` tv_set)]
1288            ; mapM_ (addErrTc . badDerivedPred) weird_preds
1289
1290            ; theta <- simplifyDeriv orig tyvars deriv_rhs
1291                 -- checkValidInstance tyvars theta clas inst_tys
1292                 -- Not necessary; see Note [Exotic derived instance contexts]
1293                 --                in TcSimplify
1294
1295            ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1296                 -- Claim: the result instance declaration is guaranteed valid
1297                 -- Hence no need to call:
1298                 --   checkValidInstance tyvars theta clas inst_tys
1299            ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution
1300
1301 ------------------------------------------------------------------
1302 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1303 mkInstance overlap_flag theta
1304             (DS { ds_name = dfun_name
1305                 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1306   = mkLocalInstance dfun overlap_flag
1307   where
1308     dfun = mkDictFunId dfun_name tyvars theta clas tys
1309
1310
1311 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1312 -- Add new locally-defined instances; don't bother to check
1313 -- for functional dependency errors -- that'll happen in TcInstDcls
1314 extendLocalInstEnv dfuns thing_inside
1315  = do { env <- getGblEnv
1316       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1317              env'      = env { tcg_inst_env = inst_env' }
1318       ; setGblEnv env' thing_inside }
1319 \end{code}
1320
1321
1322 %************************************************************************
1323 %*                                                                      *
1324 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1325 %*                                                                      *
1326 %************************************************************************
1327
1328 After all the trouble to figure out the required context for the
1329 derived instance declarations, all that's left is to chug along to
1330 produce them.  They will then be shoved into @tcInstDecls2@, which
1331 will do all its usual business.
1332
1333 There are lots of possibilities for code to generate.  Here are
1334 various general remarks.
1335
1336 PRINCIPLES:
1337 \begin{itemize}
1338 \item
1339 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1340 ``you-couldn't-do-better-by-hand'' efficient.
1341
1342 \item
1343 Deriving @Show@---also pretty common--- should also be reasonable good code.
1344
1345 \item
1346 Deriving for the other classes isn't that common or that big a deal.
1347 \end{itemize}
1348
1349 PRAGMATICS:
1350
1351 \begin{itemize}
1352 \item
1353 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1354
1355 \item
1356 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1357
1358 \item
1359 We {\em normally} generate code only for the non-defaulted methods;
1360 there are some exceptions for @Eq@ and (especially) @Ord@...
1361
1362 \item
1363 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1364 constructor's numeric (@Int#@) tag.  These are generated by
1365 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1366 these is around is given by @hasCon2TagFun@.
1367
1368 The examples under the different sections below will make this
1369 clearer.
1370
1371 \item
1372 Much less often (really just for deriving @Ix@), we use a
1373 @_tag2con_<tycon>@ function.  See the examples.
1374
1375 \item
1376 We use the renamer!!!  Reason: we're supposed to be
1377 producing @LHsBinds Name@ for the methods, but that means
1378 producing correctly-uniquified code on the fly.  This is entirely
1379 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1380 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1381 the renamer.  What a great hack!
1382 \end{itemize}
1383
1384 \begin{code}
1385 -- Generate the InstInfo for the required instance paired with the
1386 --   *representation* tycon for that instance,
1387 -- plus any auxiliary bindings required
1388 --
1389 -- Representation tycons differ from the tycon in the instance signature in
1390 -- case of instances for indexed families.
1391 --
1392 genInst :: Bool         -- True <=> standalone deriving
1393         -> OverlapFlag
1394         -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1395 genInst standalone_deriv oflag spec
1396   | ds_newtype spec
1397   = return (InstInfo { iSpec  = mkInstance oflag (ds_theta spec) spec
1398                      , iBinds = NewTypeDerived co rep_tycon }, [])
1399
1400   | otherwise
1401   = do  { let loc  = getSrcSpan (ds_name spec)
1402               inst = mkInstance oflag (ds_theta spec) spec
1403               clas = ds_cls spec
1404
1405           -- In case of a family instance, we need to use the representation
1406           -- tycon (after all, it has the data constructors)
1407         ; fix_env <- getFixityEnv
1408         ; let (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1409               binds = VanillaInst meth_binds [] standalone_deriv
1410         ; return (InstInfo { iSpec = inst, iBinds = binds }, aux_binds)
1411         }
1412   where
1413     rep_tycon   = ds_tc spec
1414     rep_tc_args = ds_tc_args spec
1415     co1 = case tyConFamilyCoercion_maybe rep_tycon of
1416               Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1417               Nothing     -> id_co
1418               -- Not a family => rep_tycon = main tycon
1419     co2 = case newTyConCo_maybe rep_tycon of
1420               Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1421               Nothing     -> id_co  -- The newtype is transparent; no need for a cast
1422     co = co1 `mkTransCoI` co2
1423     id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
1424
1425 -- Example: newtype instance N [a] = N1 (Tree a)
1426 --          deriving instance Eq b => Eq (N [(b,b)])
1427 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1428 -- When dealing with the deriving clause
1429 --    co1 : N [(b,b)] ~ R1:N (b,b)
1430 --    co2 : R1:N (b,b) ~ Tree (b,b)
1431 --    co  : N [(b,b)] ~ Tree (b,b)
1432
1433 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1434 genDerivBinds loc fix_env clas tycon
1435   | className clas `elem` typeableClassNames
1436   = (gen_Typeable_binds loc tycon, [])
1437
1438   | otherwise
1439   = case assocMaybe gen_list (getUnique clas) of
1440         Just gen_fn -> gen_fn loc tycon
1441         Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1442   where
1443     gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1444     gen_list = [(eqClassKey,       gen_Eq_binds)
1445                ,(ordClassKey,      gen_Ord_binds)
1446                ,(enumClassKey,     gen_Enum_binds)
1447                ,(boundedClassKey,  gen_Bounded_binds)
1448                ,(ixClassKey,       gen_Ix_binds)
1449                ,(showClassKey,     gen_Show_binds fix_env)
1450                ,(readClassKey,     gen_Read_binds fix_env)
1451                ,(dataClassKey,     gen_Data_binds)
1452                ,(functorClassKey,  gen_Functor_binds)
1453                ,(foldableClassKey, gen_Foldable_binds)
1454                ,(traversableClassKey, gen_Traversable_binds)
1455                ]
1456 \end{code}
1457
1458
1459 %************************************************************************
1460 %*                                                                      *
1461 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1462 %*                                                                      *
1463 %************************************************************************
1464
1465 \begin{code}
1466 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1467 derivingKindErr tc cls cls_tys cls_kind
1468   = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1469                 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1470        2 (ptext (sLit "Class") <+> quotes (ppr cls)
1471             <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1472
1473 derivingEtaErr :: Class -> [Type] -> Type -> Message
1474 derivingEtaErr cls cls_tys inst_ty
1475   = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1476          nest 2 (ptext (sLit "instance (...) =>")
1477                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1478
1479 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1480 typeFamilyPapErr tc cls cls_tys inst_ty
1481   = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1482        2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1483
1484 derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message
1485 derivingThingErr newtype_deriving clas tys ty why
1486   = sep [(hang (ptext (sLit "Can't make a derived instance of"))
1487              2 (quotes (ppr pred))
1488           $$ nest 2 extra) <> colon,
1489          nest 2 why]
1490   where
1491     extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
1492           | otherwise        = empty
1493     pred = mkClassPred clas (tys ++ [ty])
1494
1495 derivingHiddenErr :: TyCon -> SDoc
1496 derivingHiddenErr tc
1497   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1498        2 (ptext (sLit "so you cannot derive an instance for it"))
1499
1500 standaloneCtxt :: LHsType Name -> SDoc
1501 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1502                        2 (quotes (ppr ty))
1503
1504 derivInstCtxt :: Class -> [Type] -> Message
1505 derivInstCtxt clas inst_tys
1506   = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)
1507
1508 badDerivedPred :: PredType -> Message
1509 badDerivedPred pred
1510   = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1511           ptext (sLit "type variables that are not data type parameters"),
1512           nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
1513 \end{code}