ghc/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
  11                   ) where
  12
  13 #include "HsVersions.h"
  14
  15 import HsSyn
  16 import BasicTypes       ( RecFlag(..) )
  17 import RnHsSyn          ( maybeGenericMatch, extractHsTyVars )
  18 import RnExpr           ( rnLExpr )
  19 import RnEnv            ( lookupTopBndrRn, lookupImportedName )
  20
  21 import Inst             ( Inst, InstOrigin(..), instToId, newDicts, newDictsAtLoc, newMethod )
  22 import TcEnv            ( tcLookupLocatedClass, tcExtendIdEnv2,
  23                           tcExtendTyVarEnv,
  24                           InstInfo(..), pprInstInfoDetails,
  25                           simpleInstInfoTyCon, simpleInstInfoTy,
  26                           InstBindings(..), newDFunName
  27                         )
  28 import TcBinds          ( tcMonoBinds, tcSpecSigs )
  29 import TcHsType         ( TcSigInfo(..), tcHsKindedType, tcHsSigType )
  30 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  31 import TcUnify          ( checkSigTyVars, sigCtxt )
  32 import TcMType          ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ), tcSkolType )
  33 import TcType           ( Type, SkolemInfo(ClsSkol, InstSkol, SigSkol),
  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, setInlinePragma )
  48 import Name             ( Name, NamedThing(..) )
  49 import NameEnv          ( NameEnv, lookupNameEnv, mkNameEnv )
  50 import NameSet          ( emptyNameSet, unitNameSet, nameSetToList )
  51 import OccName          ( reportIfUnused, mkDefaultMethodOcc )
  52 import RdrName          ( RdrName, mkDerivedRdrName )
  53 import Outputable
  54 import PrelNames        ( genericTyConNames )
  55 import CmdLineOpts
  56 import UnicodeUtil      ( stringToUtf8 )
  57 import ErrUtils         ( dumpIfSet_dyn )
  58 import Util             ( count, lengthIs, isSingleton, lengthExceeds )
  59 import Unique           ( Uniquable(..) )
  60 import ListSetOps       ( equivClassesByUniq, minusList )
  61 import SrcLoc           ( Located(..), srcSpanStart, unLoc, noLoc )
  62 import Maybes           ( seqMaybe, isJust, mapCatMaybes )
  63 import List             ( partition )
  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 _ (Sig _ _))       <- sigs]
 122     op_names = [n   | sig@(L _ (Sig (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 (L _ op) _ (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 (Sig (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         prags                    = filter isPragLSig sigs
 250         tc_dm                    = tcDefMeth clas tyvars default_binds prags
 251
 252         dm_sel_ids               = [sel_id | (sel_id, DefMeth) <- op_items]
 253         -- Generate code for polymorphic default methods only
 254         -- (Generic default methods have turned into instance decls by now.)
 255         -- This is incompatible with Hugs, which expects a polymorphic
 256         -- default method for every class op, regardless of whether or not
 257         -- the programmer supplied an explicit default decl for the class.
 258         -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 259     in
 260     mapAndUnzipM tc_dm dm_sel_ids       `thenM` \ (defm_binds, dm_ids_s) ->
 261     returnM (listToBag defm_binds, concat dm_ids_s)
 262
 263 tcDefMeth clas tyvars binds_in prags sel_id
 264   = do  { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
 265         ; let   rigid_info  = ClsSkol clas
 266                 clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 267                 inst_tys    = mkTyVarTys clas_tyvars
 268                 dm_ty       = idType sel_id     -- Same as dict selector!
 269                 theta       = [mkClassPred clas inst_tys]
 270                 local_dm_id = mkDefaultMethodId dm_name dm_ty
 271                 origin      = SigOrigin rigid_info
 272
 273         ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
 274         ; [this_dict] <- newDicts origin theta
 275         ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta
 276                                                             [this_dict] prags meth_info)
 277
 278         ; addErrCtxt (defltMethCtxt clas) $ do
 279
 280         -- Check the context
 281         { dict_binds <- tcSimplifyCheck
 282                                 (ptext SLIT("class") <+> ppr clas)
 283                                 clas_tyvars
 284                                 [this_dict]
 285                                 insts_needed
 286
 287         -- Simplification can do unification
 288         ; checkSigTyVars clas_tyvars
 289
 290         ; let
 291                 (_,dm_inst_id,_) = meth_info
 292                 full_bind = AbsBinds
 293                                     clas_tyvars
 294                                     [instToId this_dict]
 295                                     [(clas_tyvars, local_dm_id, dm_inst_id)]
 296                                     emptyNameSet        -- No inlines (yet)
 297                                     (dict_binds `unionBags` defm_bind)
 298         ; returnM (noLoc full_bind, [local_dm_id]) }}
 299
 300 mkDefMethRdrName :: Id -> RdrName
 301 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
 302 \end{code}
 303
 304
 305 %************************************************************************
 306 %*                                                                      *
 307 \subsection{Typechecking a method}
 308 %*                                                                      *
 309 %************************************************************************
 310
 311 @tcMethodBind@ is used to type-check both default-method and
 312 instance-decl method declarations.  We must type-check methods one at a
 313 time, because their signatures may have different contexts and
 314 tyvar sets.
 315
 316 \begin{code}
 317 type MethodSpec = (Id,                  -- Global selector Id
 318                    Id,                  -- Local Id (class tyvars instantiated)
 319                    LHsBind Name)        -- Binding for the method
 320
 321 tcMethodBind
 322         :: [TcTyVar]            -- Skolemised type variables for the
 323                                 --      enclosing class/instance decl.
 324                                 --      They'll be signature tyvars, and we
 325                                 --      want to check that they don't get bound
 326                                 -- Also they are scoped, so we bring them into scope
 327                                 -- Always equal the range of the type envt
 328         -> TcThetaType          -- Available theta; it's just used for the error message
 329         -> [Inst]               -- Available from context, used to simplify constraints
 330                                 --      from the method body
 331         -> [LSig Name]          -- Pragmas (e.g. inline pragmas)
 332         -> MethodSpec           -- Details of this method
 333         -> TcM (LHsBinds Id)
 334
 335 tcMethodBind inst_tyvars inst_theta avail_insts prags
 336              (sel_id, meth_id, meth_bind)
 337   = recoverM (returnM emptyLHsBinds) $
 338         -- If anything fails, recover returning no bindings.
 339         -- This is particularly useful when checking the default-method binding of
 340         -- a class decl. If we don't recover, we don't add the default method to
 341         -- the type enviroment, and we get a tcLookup failure on $dmeth later.
 342
 343         -- Check the bindings; first adding inst_tyvars to the envt
 344         -- so that we don't quantify over them in nested places
 345
 346
 347     let -- Fake up a TcSigInfo to pass to tcMonoBinds
 348         rigid_info = SigSkol (idName meth_id)
 349     in
 350     tcSkolType rigid_info (idType meth_id)      `thenM` \ (tyvars', theta', tau') ->
 351     getInstLoc (SigOrigin rigid_info)           `thenM` \ loc ->
 352     let meth_sig = TcSigInfo { sig_id = meth_id, sig_tvs = tyvars', sig_scoped = [],
 353                                sig_theta = theta', sig_tau = tau', sig_loc = loc }
 354         lookup_sig name = ASSERT( name == idName meth_id )
 355                           Just meth_sig
 356     in
 357     tcExtendTyVarEnv inst_tyvars (
 358         addErrCtxt (methodCtxt sel_id)                  $
 359         getLIE                                          $
 360         tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive
 361     )                                                   `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
 362
 363         -- Now do context reduction.   We simplify wrt both the local tyvars
 364         -- and the ones of the class/instance decl, so that there is
 365         -- no problem with
 366         --      class C a where
 367         --        op :: Eq a => a -> b -> a
 368         --
 369         -- We do this for each method independently to localise error messages
 370
 371     addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))        $
 372     newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig)       `thenM` \ meth_dicts ->
 373     let
 374         meth_tvs   = sig_tvs meth_sig
 375         all_tyvars = meth_tvs ++ inst_tyvars
 376         all_insts  = avail_insts ++ meth_dicts
 377     in
 378     tcSimplifyCheck
 379          (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
 380          all_tyvars all_insts meth_lie          `thenM` \ lie_binds ->
 381
 382     checkSigTyVars all_tyvars                   `thenM_`
 383
 384     let
 385         sel_name = idName sel_id
 386         inline_prags  = [ (is_inl, phase)
 387                         | L _ (InlineSig is_inl (L _ name) phase) <- prags,
 388                           name == sel_name ]
 389         spec_prags = [ prag
 390                      | prag@(L _ (SpecSig (L _ name) _)) <- prags,
 391                        name == sel_name]
 392
 393                 -- Attach inline pragmas as appropriate
 394         (final_meth_id, inlines)
 395            | ((is_inline, phase) : _) <- inline_prags
 396            = (meth_id `setInlinePragma` phase,
 397               if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
 398            | otherwise
 399            = (meth_id, emptyNameSet)
 400
 401         [(_,_,local_meth_id)] = mono_bind_infos
 402         poly_meth_bind = noLoc $ AbsBinds meth_tvs
 403                                   (map instToId meth_dicts)
 404                                   [(meth_tvs, final_meth_id, local_meth_id)]
 405                                   inlines
 406                                   (lie_binds `unionBags` meth_bind)
 407
 408     in
 409         -- Deal with specialisation pragmas
 410         -- The sel_name is what appears in the pragma
 411     tcExtendIdEnv2 [(sel_name, final_meth_id)] (
 412         getLIE (tcSpecSigs spec_prags)                  `thenM` \ (spec_binds1, prag_lie) ->
 413
 414              -- The prag_lie for a SPECIALISE pragma will mention the function itself,
 415              -- so we have to simplify them away right now lest they float outwards!
 416         bindInstsOfLocalFuns prag_lie [final_meth_id]   `thenM` \ spec_binds2 ->
 417         returnM (spec_binds1 `unionBags` spec_binds2)
 418     )                                                   `thenM` \ spec_binds ->
 419
 420     returnM (poly_meth_bind `consBag` spec_binds)
 421
 422
 423 mkMethodBind :: InstOrigin
 424              -> Class -> [TcType]       -- Class and instance types
 425              -> LHsBinds Name   -- Method binding (pick the right one from in here)
 426              -> ClassOpItem
 427              -> TcM (Maybe Inst,                -- Method inst
 428                      MethodSpec)
 429 -- Find the binding for the specified method, or make
 430 -- up a suitable default method if it isn't there
 431
 432 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
 433   = mkMethId origin clas sel_id inst_tys                `thenM` \ (mb_inst, meth_id) ->
 434     let
 435         meth_name  = idName meth_id
 436     in
 437         -- Figure out what method binding to use
 438         -- If the user suppplied one, use it, else construct a default one
 439     getSrcSpanM                                 `thenM` \ loc ->
 440     (case find_bind (idName sel_id) meth_name meth_binds of
 441         Just user_bind -> returnM user_bind
 442         Nothing        ->
 443            mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
 444                 -- Not infix decl
 445            returnM (noLoc $ FunBind (noLoc meth_name) False
 446                                     (mkMatchGroup [mkSimpleMatch [] rhs]))
 447     )                                           `thenM` \ meth_bind ->
 448
 449     returnM (mb_inst, (sel_id, meth_id, meth_bind))
 450
 451 mkMethId :: InstOrigin -> Class
 452          -> Id -> [TcType]      -- Selector, and instance types
 453          -> TcM (Maybe Inst, Id)
 454
 455 -- mkMethId instantiates the selector Id at the specified types
 456 mkMethId origin clas sel_id inst_tys
 457   = let
 458         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 459         rho_ty       = ASSERT( length tyvars == length inst_tys )
 460                        substTyWith tyvars inst_tys rho
 461         (preds,tau)  = tcSplitPhiTy rho_ty
 462         first_pred   = head preds
 463     in
 464         -- The first predicate should be of form (C a b)
 465         -- where C is the class in question
 466     ASSERT( not (null preds) &&
 467             case getClassPredTys_maybe first_pred of
 468                 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
 469     )
 470     if isSingleton preds then
 471         -- If it's the only one, make a 'method'
 472         getInstLoc origin                               `thenM` \ inst_loc ->
 473         newMethod inst_loc sel_id inst_tys preds tau    `thenM` \ meth_inst ->
 474         returnM (Just meth_inst, instToId meth_inst)
 475     else
 476         -- If it's not the only one we need to be careful
 477         -- For example, given 'op' defined thus:
 478         --      class Foo a where
 479         --        op :: (?x :: String) => a -> a
 480         -- (mkMethId op T) should return an Inst with type
 481         --      (?x :: String) => T -> T
 482         -- That is, the class-op's context is still there.
 483         -- BUT: it can't be a Method any more, because it breaks
 484         --      INVARIANT 2 of methods.  (See the data decl for Inst.)
 485         newUnique                       `thenM` \ uniq ->
 486         getSrcSpanM                     `thenM` \ loc ->
 487         let
 488             real_tau = mkPhiTy (tail preds) tau
 489             meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau
 490                         (srcSpanStart loc) --TODO
 491         in
 492         returnM (Nothing, meth_id)
 493
 494      -- The user didn't supply a method binding,
 495      -- so we have to make up a default binding
 496      -- The RHS of a default method depends on the default-method info
 497 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
 498   =  -- An polymorphic default method
 499     lookupImportedName (mkDefMethRdrName sel_id)        `thenM` \ dm_name ->
 500         -- Might not be imported, but will be an OrigName
 501     traceRn (text "mkDefMeth" <+> ppr dm_name)          `thenM_`
 502     returnM (nlHsVar dm_name)
 503
 504 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
 505   =     -- No default method
 506         -- Warn only if -fwarn-missing-methods
 507     doptM Opt_WarnMissingMethods                `thenM` \ warn ->
 508     warnTc (isInstDecl origin
 509            && warn
 510            && reportIfUnused (getOccName sel_id))
 511            (omittedMethodWarn sel_id)           `thenM_`
 512     returnM error_rhs
 513   where
 514     error_rhs  = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
 515     simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
 516                        (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
 517     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 518
 519         -- When the type is of form t1 -> t2 -> t3
 520         -- make a default method like (\ _ _ -> noMethBind "blah")
 521         -- rather than simply        (noMethBind "blah")
 522         -- Reason: if t1 or t2 are higher-ranked types we get n
 523         --         silly ambiguity messages.
 524         -- Example:     f :: (forall a. Eq a => a -> a) -> Int
 525         --              f = error "urk"
 526         -- Here, tcSub tries to force (error "urk") to have the right type,
 527         -- thus:        f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
 528         -- where 't' is fresh ty var.  This leads directly to "ambiguous t".
 529         --
 530         -- NB: technically this changes the meaning of the default-default
 531         --     method slightly, because `seq` can see the lambdas.  Oh well.
 532     (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
 533     (_,_,tau2)    = tcSplitSigmaTy tau1
 534         -- Need two splits because the  selector can have a type like
 535         --      forall a. Foo a => forall b. Eq b => ...
 536     (arg_tys, _) = tcSplitFunTys tau2
 537     wild_pats    = [nlWildPat | ty <- arg_tys]
 538
 539 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 540   =     -- A generic default method
 541         -- If the method is defined generically, we can only do the job if the
 542         -- instance declaration is for a single-parameter type class with
 543         -- a type constructor applied to type arguments in the instance decl
 544         --      (checkTc, so False provokes the error)
 545     ASSERT( isInstDecl origin ) -- We never get here from a class decl
 546     do  { checkTc (isJust maybe_tycon)
 547                   (badGenericInstance sel_id (notSimple inst_tys))
 548         ; checkTc (tyConHasGenerics tycon)
 549                   (badGenericInstance sel_id (notGeneric tycon))
 550
 551         ; dflags <- getDOpts
 552         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 553                    (vcat [ppr clas <+> ppr inst_tys,
 554                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 555
 556                 -- Rename it before returning it
 557         ; (rn_rhs, _) <- rnLExpr rhs
 558         ; returnM rn_rhs }
 559   where
 560     rhs = mkGenericRhs sel_id clas_tyvar tycon
 561
 562           -- The tycon is only used in the generic case, and in that
 563           -- case we require that the instance decl is for a single-parameter
 564           -- type class with type variable arguments:
 565           --    instance (...) => C (T a b)
 566     clas_tyvar    = head (classTyVars clas)
 567     Just tycon    = maybe_tycon
 568     maybe_tycon   = case inst_tys of
 569                         [ty] -> case tcSplitTyConApp_maybe ty of
 570                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 571                                   other                                           -> Nothing
 572                         other -> Nothing
 573
 574 isInstDecl (SigOrigin (InstSkol _)) = True
 575 isInstDecl (SigOrigin (ClsSkol _))  = False
 576 \end{code}
 577
 578
 579 \begin{code}
 580 -- The renamer just puts the selector ID as the binder in the method binding
 581 -- but we must use the method name; so we substitute it here.  Crude but simple.
 582 find_bind sel_name meth_name binds
 583   = foldlBag seqMaybe Nothing (mapBag f binds)
 584   where
 585         f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name
 586                 = Just (L loc1 (FunBind (L loc2 meth_name) fix matches))
 587         f _other = Nothing
 588 \end{code}
 589
 590
 591 %************************************************************************
 592 %*                                                                      *
 593 \subsection{Extracting generic instance declaration from class declarations}
 594 %*                                                                      *
 595 %************************************************************************
 596
 597 @getGenericInstances@ extracts the generic instance declarations from a class
 598 declaration.  For exmaple
 599
 600         class C a where
 601           op :: a -> a
 602
 603           op{ x+y } (Inl v)   = ...
 604           op{ x+y } (Inr v)   = ...
 605           op{ x*y } (v :*: w) = ...
 606           op{ 1   } Unit      = ...
 607
 608 gives rise to the instance declarations
 609
 610         instance C (x+y) where
 611           op (Inl v)   = ...
 612           op (Inr v)   = ...
 613
 614         instance C (x*y) where
 615           op (v :*: w) = ...
 616
 617         instance C 1 where
 618           op Unit      = ...
 619
 620
 621 \begin{code}
 622 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
 623 getGenericInstances class_decls
 624   = do  { gen_inst_infos <- mappM (addLocM get_generics) class_decls
 625         ; let { gen_inst_info = concat gen_inst_infos }
 626
 627         -- Return right away if there is no generic stuff
 628         ; if null gen_inst_info then returnM []
 629           else do
 630
 631         -- Otherwise print it out
 632         { dflags <- getDOpts
 633         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 634                    (vcat (map pprInstInfoDetails gen_inst_info)))
 635         ; returnM gen_inst_info }}
 636
 637 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 638   | null generic_binds
 639   = returnM [] -- The comon case: no generic default methods
 640
 641   | otherwise   -- A source class decl with generic default methods
 642   = recoverM (returnM [])                               $
 643     tcAddDeclCtxt decl                                  $
 644     tcLookupLocatedClass class_name                     `thenM` \ clas ->
 645
 646         -- Group by type, and
 647         -- make an InstInfo out of each group
 648     let
 649         groups = groupWith listToBag generic_binds
 650     in
 651     mappM (mkGenericInstance clas) groups               `thenM` \ inst_infos ->
 652
 653         -- Check that there is only one InstInfo for each type constructor
 654         -- The main way this can fail is if you write
 655         --      f {| a+b |} ... = ...
 656         --      f {| x+y |} ... = ...
 657         -- Then at this point we'll have an InstInfo for each
 658     let
 659         tc_inst_infos :: [(TyCon, InstInfo)]
 660         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 661
 662         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 663                               group `lengthExceeds` 1]
 664         get_uniq (tc,_) = getUnique tc
 665     in
 666     mappM (addErrTc . dupGenericInsts) bad_groups       `thenM_`
 667
 668         -- Check that there is an InstInfo for each generic type constructor
 669     let
 670         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 671     in
 672     checkTc (null missing) (missingGenericInstances missing)    `thenM_`
 673
 674     returnM inst_infos
 675   where
 676     generic_binds :: [(HsType Name, LHsBind Name)]
 677     generic_binds = getGenericBinds def_methods
 678
 679
 680 ---------------------------------
 681 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 682   -- Takes a group of method bindings, finds the generic ones, and returns
 683   -- them in finite map indexed by the type parameter in the definition.
 684 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 685
 686 getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty)))
 687   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 688   where
 689     wrap ms = L loc (FunBind id infixop (MatchGroup ms ty))
 690 getGenericBind _
 691   = []
 692
 693 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 694 groupWith op []          = []
 695 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 696     where
 697       vs            = map snd this
 698       (this,rest)   = partition same_t prs
 699       same_t (t',v) = t `eqPatType` t'
 700
 701 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 702 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 703
 704 eqPatType :: HsType Name -> HsType Name -> Bool
 705 -- A very simple equality function, only for
 706 -- type patterns in generic function definitions.
 707 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 708 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
 709 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
 710 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 711 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 712 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 713 eqPatType _ _ = False
 714
 715 ---------------------------------
 716 mkGenericInstance :: Class
 717                   -> (HsType Name, LHsBinds Name)
 718                   -> TcM InstInfo
 719
 720 mkGenericInstance clas (hs_ty, binds)
 721   -- Make a generic instance declaration
 722   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 723
 724   =     -- Extract the universally quantified type variables
 725         -- and wrap them as forall'd tyvars, so that kind inference
 726         -- works in the standard way
 727     let
 728         sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
 729         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 730     in
 731         -- Type-check the instance type, and check its form
 732     tcHsSigType GenPatCtxt hs_forall_ty         `thenM` \ forall_inst_ty ->
 733     let
 734         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 735     in
 736     checkTc (validGenericInstanceType inst_ty)
 737             (badGenericInstanceType binds)      `thenM_`
 738
 739         -- Make the dictionary function.
 740     getSrcSpanM                                         `thenM` \ span ->
 741     newDFunName clas [inst_ty] (srcSpanStart span)      `thenM` \ dfun_name ->
 742     let
 743         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 744         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 745     in
 746
 747     returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
 748 \end{code}
 749
 750
 751 %************************************************************************
 752 %*                                                                      *
 753                 Error messages
 754 %*                                                                      *
 755 %************************************************************************
 756
 757 \begin{code}
 758 tcAddDeclCtxt decl thing_inside
 759   = addErrCtxt ctxt thing_inside
 760   where
 761      thing = case decl of
 762                 ClassDecl {}              -> "class"
 763                 TySynonym {}              -> "type synonym"
 764                 TyData {tcdND = NewType}  -> "newtype"
 765                 TyData {tcdND = DataType} -> "data type"
 766
 767      ctxt = hsep [ptext SLIT("In the"), text thing,
 768                   ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 769
 770 defltMethCtxt clas
 771   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 772
 773 methodCtxt sel_id
 774   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 775
 776 badMethodErr clas op
 777   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 778           ptext SLIT("does not have a method"), quotes (ppr op)]
 779
 780 omittedMethodWarn sel_id
 781   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 782
 783 badGenericInstance sel_id because
 784   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 785          because]
 786
 787 notSimple inst_tys
 788   = vcat [ptext SLIT("because the instance type(s)"),
 789           nest 2 (ppr inst_tys),
 790           ptext SLIT("is not a simple type of form (T a b c)")]
 791
 792 notGeneric tycon
 793   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
 794           ptext SLIT("was not compiled with -fgenerics")]
 795
 796 badGenericInstanceType binds
 797   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 798           nest 4 (ppr binds)]
 799
 800 missingGenericInstances missing
 801   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 802
 803 dupGenericInsts tc_inst_infos
 804   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 805           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 806           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 807     ]
 808   where
 809     ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
 810
 811 mixedGenericErr op
 812   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 813 \end{code}