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