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