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