compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Typechecking class declarations
   7
   8 \begin{code}
   9 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module TcClassDcl ( tcClassSigs, tcClassDecl2,
  17                     getGenericInstances,
  18                     MethodSpec, tcMethodBind, mkMethId,
  19                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
  20                   ) where
  21
  22 #include "HsVersions.h"
  23
  24 import HsSyn
  25 import RnHsSyn
  26 import RnExpr
  27 import RnEnv
  28 import Inst
  29 import InstEnv
  30 import TcEnv
  31 import TcBinds
  32 import TcHsType
  33 import TcSimplify
  34 import TcUnify
  35 import TcMType
  36 import TcType
  37 import TcRnMonad
  38 import Generics
  39 import PrelInfo
  40 import Class
  41 import TyCon
  42 import Type
  43 import MkId
  44 import Id
  45 import Name
  46 import NameEnv
  47 import NameSet
  48 import OccName
  49 import RdrName
  50 import Outputable
  51 import PrelNames
  52 import DynFlags
  53 import ErrUtils
  54 import Util
  55 import Unique
  56 import ListSetOps
  57 import SrcLoc
  58 import Maybes
  59 import List
  60 import BasicTypes
  61 import Bag
  62 import FastString
  63
  64 import Control.Monad
  65 \end{code}
  66
  67
  68 Dictionary handling
  69 ~~~~~~~~~~~~~~~~~~~
  70 Every class implicitly declares a new data type, corresponding to dictionaries
  71 of that class. So, for example:
  72
  73         class (D a) => C a where
  74           op1 :: a -> a
  75           op2 :: forall b. Ord b => a -> b -> b
  76
  77 would implicitly declare
  78
  79         data CDict a = CDict (D a)
  80                              (a -> a)
  81                              (forall b. Ord b => a -> b -> b)
  82
  83 (We could use a record decl, but that means changing more of the existing apparatus.
  84 One step at at time!)
  85
  86 For classes with just one superclass+method, we use a newtype decl instead:
  87
  88         class C a where
  89           op :: forallb. a -> b -> b
  90
  91 generates
  92
  93         newtype CDict a = CDict (forall b. a -> b -> b)
  94
  95 Now DictTy in Type is just a form of type synomym:
  96         DictTy c t = TyConTy CDict `AppTy` t
  97
  98 Death to "ExpandingDicts".
  99
 100
 101 %************************************************************************
 102 %*                                                                      *
 103                 Type-checking the class op signatures
 104 %*                                                                      *
 105 %************************************************************************
 106
 107 \begin{code}
 108 tcClassSigs :: Name                     -- Name of the class
 109             -> [LSig Name]
 110             -> LHsBinds Name
 111             -> TcM [TcMethInfo]
 112
 113 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
 114                                         -- between tcClassSigs and buildClass
 115 tcClassSigs clas sigs def_methods
 116   = do { dm_env <- checkDefaultBinds clas op_names def_methods
 117        ; mapM (tcClassSig dm_env) op_sigs }
 118   where
 119     op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
 120     op_names = [n   | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
 121
 122
 123 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
 124   -- Check default bindings
 125   --    a) must be for a class op for this class
 126   --    b) must be all generic or all non-generic
 127   -- and return a mapping from class-op to Bool
 128   --    where True <=> it's a generic default method
 129 checkDefaultBinds clas ops binds
 130   = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
 131        return (mkNameEnv dm_infos)
 132
 133 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
 134   = do {        -- Check that the op is from this class
 135         checkTc (op `elem` ops) (badMethodErr clas op)
 136
 137         -- Check that all the defns ar generic, or none are
 138     ;   checkTc (all_generic || none_generic) (mixedGenericErr op)
 139
 140     ;   return (op, all_generic)
 141     }
 142   where
 143     n_generic    = count (isJust . maybeGenericMatch) matches
 144     none_generic = n_generic == 0
 145     all_generic  = matches `lengthIs` n_generic
 146
 147
 148 tcClassSig :: NameEnv Bool              -- Info about default methods;
 149            -> LSig Name
 150            -> TcM TcMethInfo
 151
 152 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
 153   = setSrcSpan loc $ do
 154     { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
 155     ; let dm = case lookupNameEnv dm_env op_name of
 156                 Nothing    -> NoDefMeth
 157                 Just False -> DefMeth
 158                 Just True  -> GenDefMeth
 159     ; return (op_name, dm, op_ty) }
 160 \end{code}
 161
 162
 163 %************************************************************************
 164 %*                                                                      *
 165                 Class Declarations
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 \begin{code}
 170 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
 171              -> TcM (LHsBinds Id, [Id])
 172
 173 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 174                                 tcdMeths = default_binds}))
 175   = recoverM (return (emptyLHsBinds, []))       $
 176     setSrcSpan loc                              $ do
 177     clas <- tcLookupLocatedClass class_name
 178
 179         -- We make a separate binding for each default method.
 180         -- At one time I used a single AbsBinds for all of them, thus
 181         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 182         -- But that desugars into
 183         --      ds = \d -> (..., ..., ...)
 184         --      dm1 = \d -> case ds d of (a,b,c) -> a
 185         -- And since ds is big, it doesn't get inlined, so we don't get good
 186         -- default methods.  Better to make separate AbsBinds for each
 187     let
 188         (tyvars, _, _, op_items) = classBigSig clas
 189         rigid_info               = ClsSkol clas
 190         origin                   = SigOrigin rigid_info
 191         prag_fn                  = mkPragFun sigs
 192         sig_fn                   = mkTcSigFun sigs
 193         clas_tyvars              = tcSkolSigTyVars rigid_info tyvars
 194         tc_dm                    = tcDefMeth origin clas clas_tyvars
 195                                              default_binds sig_fn prag_fn
 196
 197         dm_sel_ids               = [sel_id | (sel_id, DefMeth) <- op_items]
 198         -- Generate code for polymorphic default methods only
 199         -- (Generic default methods have turned into instance decls by now.)
 200         -- This is incompatible with Hugs, which expects a polymorphic
 201         -- default method for every class op, regardless of whether or not
 202         -- the programmer supplied an explicit default decl for the class.
 203         -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 204
 205     (defm_binds, dm_ids_s) <- mapAndUnzipM tc_dm dm_sel_ids
 206     return (listToBag defm_binds, concat dm_ids_s)
 207
 208 tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
 209   = do  { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
 210         ; let   inst_tys    = mkTyVarTys tyvars
 211                 dm_ty       = idType sel_id     -- Same as dict selector!
 212                 cls_pred    = mkClassPred clas inst_tys
 213                 local_dm_id = mkDefaultMethodId dm_name dm_ty
 214
 215         ; loc <- getInstLoc origin
 216         ; this_dict <- newDictBndr loc cls_pred
 217         ; (_, meth_id) <- mkMethId origin clas sel_id inst_tys
 218         ; (defm_bind, insts_needed) <- getLIE $
 219                 tcMethodBind origin tyvars [cls_pred] this_dict []
 220                              sig_fn prag_fn binds_in
 221                              (sel_id, DefMeth) meth_id
 222
 223         ; addErrCtxt (defltMethCtxt clas) $ do
 224
 225         -- Check the context
 226         { dict_binds <- tcSimplifyCheck
 227                                 loc
 228                                 tyvars
 229                                 [this_dict]
 230                                 insts_needed
 231
 232         -- Simplification can do unification
 233         ; checkSigTyVars tyvars
 234
 235         -- Inline pragmas
 236         -- We'll have an inline pragma on the local binding, made by tcMethodBind
 237         -- but that's not enough; we want one on the global default method too
 238         -- Specialisations, on the other hand, belong on the thing inside only, I think
 239         ; let sel_name         = idName sel_id
 240               inline_prags     = filter isInlineLSig (prag_fn sel_name)
 241         ; prags <- tcPrags meth_id inline_prags
 242
 243         ; let full_bind = AbsBinds  tyvars
 244                                     [instToId this_dict]
 245                                     [(tyvars, local_dm_id, meth_id, prags)]
 246                                     (dict_binds `unionBags` defm_bind)
 247         ; return (noLoc full_bind, [local_dm_id]) }}
 248
 249 mkDefMethRdrName :: Id -> RdrName
 250 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
 251 \end{code}
 252
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection{Typechecking a method}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 @tcMethodBind@ is used to type-check both default-method and
 261 instance-decl method declarations.  We must type-check methods one at a
 262 time, because their signatures may have different contexts and
 263 tyvar sets.
 264
 265 \begin{code}
 266 type MethodSpec = (Id,                  -- Global selector Id
 267                    Id,                  -- Local Id (class tyvars instantiated)
 268                    LHsBind Name)        -- Binding for the method
 269
 270 tcMethodBind
 271         :: InstOrigin
 272         -> [TcTyVar]            -- Skolemised type variables for the
 273                                 --      enclosing class/instance decl.
 274                                 --      They'll be signature tyvars, and we
 275                                 --      want to check that they don't get bound
 276                                 -- Also they are scoped, so we bring them into scope
 277                                 -- Always equal the range of the type envt
 278         -> TcThetaType          -- Available theta; it's just used for the error message
 279         -> Inst                 -- Current dictionary (this_dict)
 280         -> [Inst]               -- Other stuff available from context, used to simplify
 281                                 --   constraints from the method body (exclude this_dict)
 282         -> TcSigFun             -- For scoped tyvars, indexed by sel_name
 283         -> TcPragFun            -- Pragmas (e.g. inline pragmas), indexed by sel_name
 284         -> LHsBinds Name        -- Method binding (pick the right one from in here)
 285         -> ClassOpItem
 286         -> TcId                 -- The method Id
 287         -> TcM (LHsBinds Id)
 288
 289 tcMethodBind origin inst_tyvars inst_theta
 290              this_dict extra_insts
 291              sig_fn prag_fn meth_binds
 292              (sel_id, dm_info) meth_id
 293   | Just user_bind <- find_bind sel_name meth_name meth_binds
 294   =             -- If there is a user-supplied method binding, typecheck it
 295     tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts)
 296                    sig_fn prag_fn
 297                    sel_id meth_id user_bind
 298
 299   | otherwise   -- The user didn't supply a method binding, so we have to make
 300                 -- up a default binding, in a way depending on the default-method info
 301   = case dm_info of
 302       NoDefMeth -> do   { warn <- doptM Opt_WarnMissingMethods
 303                         ; warnTc (isInstDecl origin
 304                                    && warn   -- Warn only if -fwarn-missing-methods
 305                                    && reportIfUnused (getOccName sel_id))
 306                                              -- Don't warn about _foo methods
 307                                  (omittedMethodWarn sel_id)
 308                         ; return (unitBag $ L loc (VarBind meth_id error_rhs)) }
 309
 310       DefMeth ->   do   {       -- An polymorphic default method
 311                                 -- Might not be imported, but will be an OrigName
 312                           dm_name <- lookupImportedName (mkDefMethRdrName sel_id)
 313                         ; dm_id   <- tcLookupId dm_name
 314                                 -- Note [Default methods in instances]
 315                         ; return (unitBag $ L loc (VarBind meth_id (mk_dm_app dm_id))) }
 316
 317       GenDefMeth -> ASSERT( isInstDecl origin ) -- We never get here from a class decl
 318                     do  { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
 319                         ; tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts)
 320                                          sig_fn prag_fn
 321                                          sel_id meth_id meth_bind }
 322
 323   where
 324     meth_name = idName meth_id
 325     sel_name  = idName sel_id
 326     loc       = getSrcSpan meth_id
 327     (clas, inst_tys) = getDictClassTys this_dict
 328
 329     this_dict_id = instToId this_dict
 330     error_id     = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
 331     error_id_app = mkLHsWrap (WpTyApp (idType meth_id)) error_id
 332     error_rhs    = mkHsApp error_id_app $ L loc $
 333                    HsLit (HsStringPrim (mkFastString error_msg))
 334     error_msg    = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 335
 336     mk_dm_app dm_id     -- dm tys inst_dict
 337         = mkLHsWrap (WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys)
 338                     (L loc (HsVar dm_id))
 339
 340
 341 ---------------------------
 342 tc_method_bind inst_tyvars inst_theta avail_insts sig_fn prag_fn
 343               sel_id meth_id meth_bind
 344   = recoverM (return emptyLHsBinds) $
 345         -- If anything fails, recover returning no bindings.
 346         -- This is particularly useful when checking the default-method binding of
 347         -- a class decl. If we don't recover, we don't add the default method to
 348         -- the type enviroment, and we get a tcLookup failure on $dmeth later.
 349
 350         -- Check the bindings; first adding inst_tyvars to the envt
 351         -- so that we don't quantify over them in nested places
 352
 353     do  { let sel_name  = idName sel_id
 354               meth_name = idName meth_id
 355               meth_sig_fn name = ASSERT( name == meth_name ) sig_fn sel_name
 356                 -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
 357
 358         ; ((meth_bind, mono_bind_infos), meth_lie)
 359                <- tcExtendTyVarEnv inst_tyvars      $
 360                   tcExtendIdEnv [meth_id]           $ -- In scope for tcInstSig
 361                   addErrCtxt (methodCtxt sel_id)    $
 362                   getLIE                            $
 363                   tcMonoBinds [meth_bind] meth_sig_fn Recursive
 364
 365                 -- Now do context reduction.   We simplify wrt both the local tyvars
 366                 -- and the ones of the class/instance decl, so that there is
 367                 -- no problem with
 368                 --      class C a where
 369                 --        op :: Eq a => a -> b -> a
 370                 --
 371                 -- We do this for each method independently to localise error messages
 372
 373         ; let [(_, Just sig, local_meth_id)] = mono_bind_infos
 374               loc = sig_loc sig
 375
 376         ; addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ do
 377         { meth_dicts <- newDictBndrs loc (sig_theta sig)
 378         ; let meth_tvs   = sig_tvs sig
 379               all_tyvars = meth_tvs ++ inst_tyvars
 380               all_insts  = avail_insts ++ meth_dicts
 381
 382         ; lie_binds <- tcSimplifyCheck loc all_tyvars all_insts meth_lie
 383
 384         ; checkSigTyVars all_tyvars
 385
 386         ; prags <- tcPrags meth_id (prag_fn sel_name)
 387         ; let poly_meth_bind = noLoc $ AbsBinds meth_tvs
 388                                   (map instToId meth_dicts)
 389                                   [(meth_tvs, meth_id, local_meth_id, prags)]
 390                                   (lie_binds `unionBags` meth_bind)
 391
 392         ; return (unitBag poly_meth_bind) }}
 393
 394
 395 ---------------------------
 396 mkMethId :: InstOrigin -> Class
 397          -> Id -> [TcType]      -- Selector, and instance types
 398          -> TcM (Maybe Inst, Id)
 399
 400 -- mkMethId instantiates the selector Id at the specified types
 401 mkMethId origin clas sel_id inst_tys
 402   = let
 403         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 404         rho_ty       = ASSERT( length tyvars == length inst_tys )
 405                        substTyWith tyvars inst_tys rho
 406         (preds,tau)  = tcSplitPhiTy rho_ty
 407         first_pred   = ASSERT( not (null preds)) head preds
 408     in
 409         -- The first predicate should be of form (C a b)
 410         -- where C is the class in question
 411     ASSERT( not (null preds) &&
 412             case getClassPredTys_maybe first_pred of
 413                 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
 414     )
 415     if isSingleton preds then do
 416         -- If it's the only one, make a 'method'
 417         inst_loc <- getInstLoc origin
 418         meth_inst <- newMethod inst_loc sel_id inst_tys
 419         return (Just meth_inst, instToId meth_inst)
 420     else do
 421         -- If it's not the only one we need to be careful
 422         -- For example, given 'op' defined thus:
 423         --      class Foo a where
 424         --        op :: (?x :: String) => a -> a
 425         -- (mkMethId op T) should return an Inst with type
 426         --      (?x :: String) => T -> T
 427         -- That is, the class-op's context is still there.
 428         -- BUT: it can't be a Method any more, because it breaks
 429         --      INVARIANT 2 of methods.  (See the data decl for Inst.)
 430         uniq <- newUnique
 431         loc <- getSrcSpanM
 432         let
 433             real_tau = mkPhiTy (tail preds) tau
 434             meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
 435
 436         return (Nothing, meth_id)
 437
 438 ---------------------------
 439 -- The renamer just puts the selector ID as the binder in the method binding
 440 -- but we must use the method name; so we substitute it here.  Crude but simple.
 441 find_bind :: Name -> Name       -- Selector and method name
 442           -> LHsBinds Name              -- A group of bindings
 443           -> Maybe (LHsBind Name)       -- The binding, with meth_name replacing sel_name
 444 find_bind sel_name meth_name binds
 445   = foldlBag mplus Nothing (mapBag f binds)
 446   where
 447         f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
 448                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
 449         f _other = Nothing
 450
 451 ---------------------------
 452 mkGenericDefMethBind clas inst_tys sel_id meth_name
 453   =     -- A generic default method
 454         -- If the method is defined generically, we can only do the job if the
 455         -- instance declaration is for a single-parameter type class with
 456         -- a type constructor applied to type arguments in the instance decl
 457         --      (checkTc, so False provokes the error)
 458     do  { checkTc (isJust maybe_tycon)
 459                   (badGenericInstance sel_id (notSimple inst_tys))
 460         ; checkTc (tyConHasGenerics tycon)
 461                   (badGenericInstance sel_id (notGeneric tycon))
 462
 463         ; dflags <- getDOpts
 464         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 465                    (vcat [ppr clas <+> ppr inst_tys,
 466                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 467
 468                 -- Rename it before returning it
 469         ; (rn_rhs, _) <- rnLExpr rhs
 470         ; return (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rn_rhs]) }
 471   where
 472     rhs = mkGenericRhs sel_id clas_tyvar tycon
 473
 474           -- The tycon is only used in the generic case, and in that
 475           -- case we require that the instance decl is for a single-parameter
 476           -- type class with type variable arguments:
 477           --    instance (...) => C (T a b)
 478     clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
 479     Just tycon  = maybe_tycon
 480     maybe_tycon = case inst_tys of
 481                         [ty] -> case tcSplitTyConApp_maybe ty of
 482                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 483                                   other                                           -> Nothing
 484                         other -> Nothing
 485
 486 isInstDecl (SigOrigin InstSkol)    = True
 487 isInstDecl (SigOrigin (ClsSkol _)) = False
 488 \end{code}
 489
 490
 491 Note [Default methods]
 492 ~~~~~~~~~~~~~~~~~~~~~~~
 493 The default methods for a class are each passed a dictionary for the
 494 class, so that they get access to the other methods at the same type.
 495 So, given the class decl
 496
 497     class Foo a where
 498         op1 :: a -> Bool
 499         op2 :: forall b. Ord b => a -> b -> b -> b
 500
 501         op1 x = True
 502         op2 x y z = if (op1 x) && (y < z) then y else z
 503
 504 we get the default methods:
 505
 506     $dmop1 :: forall a. Foo a => a -> Bool
 507     $dmop1 = /\a -> \dfoo -> \x -> True
 508
 509     $dmop2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 510     $dmop2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 511                   if (op1 a dfoo x) && (< b dord y z) then y else z
 512
 513 When we come across an instance decl, we may need to use the default methods:
 514
 515     instance Foo Int where {}
 516
 517     $dFooInt :: Foo Int
 518     $dFooInt = MkFoo ($dmop1 Int $dFooInt)
 519                      ($dmop2 Int $dFooInt)
 520
 521 Notice that, as with method selectors above, we assume that dictionary
 522 application is curried, so there's no need to mention the Ord dictionary
 523 in the application of $dmop2.
 524
 525    instance Foo a => Foo [a] where {}
 526
 527    $dFooList :: forall a. Foo a -> Foo [a]
 528    $dFooList = /\ a -> \ dfoo_a ->
 529               let rec
 530                 op1 = defm.Foo.op1 [a] dfoo_list
 531                 op2 = defm.Foo.op2 [a] dfoo_list
 532                 dfoo_list = MkFoo ($dmop1 [a] dfoo_list)
 533                                   ($dmop2 [a] dfoo_list)
 534               in
 535               dfoo_list
 536
 537 Note [Default methods in instances]
 538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 539 Consider this
 540
 541    class Baz v x where
 542       foo :: x -> x
 543       foo y = y
 544
 545    instance Baz Int Int
 546
 547 From the class decl we get
 548
 549    $dmfoo :: forall v x. Baz v x => x -> x
 550
 551 Notice that the type is ambiguous.  That's fine, though. The instance decl generates
 552
 553    $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
 554
 555 BUT this does mean we must generate the dictionary translation directly, rather
 556 than generating source-code and type-checking it.  That was the bug ing
 557 Trac #1061. In any case it's less work to generate the translated version!
 558
 559
 560 %************************************************************************
 561 %*                                                                      *
 562 \subsection{Extracting generic instance declaration from class declarations}
 563 %*                                                                      *
 564 %************************************************************************
 565
 566 @getGenericInstances@ extracts the generic instance declarations from a class
 567 declaration.  For exmaple
 568
 569         class C a where
 570           op :: a -> a
 571
 572           op{ x+y } (Inl v)   = ...
 573           op{ x+y } (Inr v)   = ...
 574           op{ x*y } (v :*: w) = ...
 575           op{ 1   } Unit      = ...
 576
 577 gives rise to the instance declarations
 578
 579         instance C (x+y) where
 580           op (Inl v)   = ...
 581           op (Inr v)   = ...
 582
 583         instance C (x*y) where
 584           op (v :*: w) = ...
 585
 586         instance C 1 where
 587           op Unit      = ...
 588
 589
 590 \begin{code}
 591 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
 592 getGenericInstances class_decls
 593   = do  { gen_inst_infos <- mapM (addLocM get_generics) class_decls
 594         ; let { gen_inst_info = concat gen_inst_infos }
 595
 596         -- Return right away if there is no generic stuff
 597         ; if null gen_inst_info then return []
 598           else do
 599
 600         -- Otherwise print it out
 601         { dflags <- getDOpts
 602         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 603                  (vcat (map pprInstInfoDetails gen_inst_info)))
 604         ; return gen_inst_info }}
 605
 606 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 607   | null generic_binds
 608   = return [] -- The comon case: no generic default methods
 609
 610   | otherwise   -- A source class decl with generic default methods
 611   = recoverM (return [])                                $
 612     tcAddDeclCtxt decl                                  $ do
 613     clas <- tcLookupLocatedClass class_name
 614
 615         -- Group by type, and
 616         -- make an InstInfo out of each group
 617     let
 618         groups = groupWith listToBag generic_binds
 619
 620     inst_infos <- mapM (mkGenericInstance clas) groups
 621
 622         -- Check that there is only one InstInfo for each type constructor
 623         -- The main way this can fail is if you write
 624         --      f {| a+b |} ... = ...
 625         --      f {| x+y |} ... = ...
 626         -- Then at this point we'll have an InstInfo for each
 627         --
 628         -- The class should be unary, which is why simpleInstInfoTyCon should be ok
 629     let
 630         tc_inst_infos :: [(TyCon, InstInfo)]
 631         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 632
 633         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 634                               group `lengthExceeds` 1]
 635         get_uniq (tc,_) = getUnique tc
 636
 637     mapM (addErrTc . dupGenericInsts) bad_groups
 638
 639         -- Check that there is an InstInfo for each generic type constructor
 640     let
 641         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 642
 643     checkTc (null missing) (missingGenericInstances missing)
 644
 645     return inst_infos
 646   where
 647     generic_binds :: [(HsType Name, LHsBind Name)]
 648     generic_binds = getGenericBinds def_methods
 649
 650
 651 ---------------------------------
 652 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 653   -- Takes a group of method bindings, finds the generic ones, and returns
 654   -- them in finite map indexed by the type parameter in the definition.
 655 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 656
 657 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
 658   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 659   where
 660     wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
 661 getGenericBind _
 662   = []
 663
 664 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 665 groupWith op []          = []
 666 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 667     where
 668       vs            = map snd this
 669       (this,rest)   = partition same_t prs
 670       same_t (t',v) = t `eqPatType` t'
 671
 672 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 673 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 674
 675 eqPatType :: HsType Name -> HsType Name -> Bool
 676 -- A very simple equality function, only for
 677 -- type patterns in generic function definitions.
 678 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 679 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
 680 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
 681 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 682 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 683 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 684 eqPatType _ _ = False
 685
 686 ---------------------------------
 687 mkGenericInstance :: Class
 688                   -> (HsType Name, LHsBinds Name)
 689                   -> TcM InstInfo
 690
 691 mkGenericInstance clas (hs_ty, binds) = do
 692   -- Make a generic instance declaration
 693   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 694
 695         -- Extract the universally quantified type variables
 696         -- and wrap them as forall'd tyvars, so that kind inference
 697         -- works in the standard way
 698     let
 699         sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
 700         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 701
 702         -- Type-check the instance type, and check its form
 703     forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
 704     let
 705         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 706
 707     checkTc (validGenericInstanceType inst_ty)
 708             (badGenericInstanceType binds)
 709
 710         -- Make the dictionary function.
 711     span <- getSrcSpanM
 712     overlap_flag <- getOverlapFlag
 713     dfun_name <- newDFunName clas [inst_ty] span
 714     let
 715         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 716         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 717         ispec      = mkLocalInstance dfun_id overlap_flag
 718
 719     return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
 720 \end{code}
 721
 722
 723 %************************************************************************
 724 %*                                                                      *
 725                 Error messages
 726 %*                                                                      *
 727 %************************************************************************
 728
 729 \begin{code}
 730 tcAddDeclCtxt decl thing_inside
 731   = addErrCtxt ctxt thing_inside
 732   where
 733      thing | isClassDecl decl  = "class"
 734            | isTypeDecl decl   = "type synonym" ++ maybeInst
 735            | isDataDecl decl   = if tcdND decl == NewType
 736                                  then "newtype" ++ maybeInst
 737                                  else "data type" ++ maybeInst
 738            | isFamilyDecl decl = "family"
 739
 740      maybeInst | isFamInstDecl decl = " instance"
 741                | otherwise          = ""
 742
 743      ctxt = hsep [ptext (sLit "In the"), text thing,
 744                   ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
 745
 746 defltMethCtxt clas
 747   = ptext (sLit "When checking the default methods for class") <+> quotes (ppr clas)
 748
 749 methodCtxt sel_id
 750   = ptext (sLit "In the definition for method") <+> quotes (ppr sel_id)
 751
 752 badMethodErr clas op
 753   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 754           ptext (sLit "does not have a method"), quotes (ppr op)]
 755
 756 badATErr clas at
 757   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 758           ptext (sLit "does not have an associated type"), quotes (ppr at)]
 759
 760 omittedMethodWarn sel_id
 761   = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
 762
 763 omittedATWarn at
 764   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 765
 766 badGenericInstance sel_id because
 767   = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
 768          because]
 769
 770 notSimple inst_tys
 771   = vcat [ptext (sLit "because the instance type(s)"),
 772           nest 2 (ppr inst_tys),
 773           ptext (sLit "is not a simple type of form (T a1 ... an)")]
 774
 775 notGeneric tycon
 776   = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
 777           ptext (sLit "was not compiled with -fgenerics")]
 778
 779 badGenericInstanceType binds
 780   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
 781           nest 4 (ppr binds)]
 782
 783 missingGenericInstances missing
 784   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
 785
 786 dupGenericInsts tc_inst_infos
 787   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
 788           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 789           ptext (sLit "All the type patterns for a generic type constructor must be identical")
 790     ]
 791   where
 792     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 793
 794 mixedGenericErr op
 795   = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 796 \end{code}