compiler/typecheck/TcClassDcl.lhs

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