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(..), mkTcSig, tcHsKindedType, tcHsSigType )
  30 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  31 import TcUnify          ( checkSigTyVars, sigCtxt )
  32 import TcMType          ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ) )
  33 import TcType           ( Type, SkolemInfo(ClsSkol, InstSkol),
  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 (isPragSig.unLoc) 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      mkTcSig meth_id                            `thenM` \ meth_sig ->
 346      let lookup_sig name = ASSERT( name == idName meth_id )
 347                            Just meth_sig
 348      in
 349      tcExtendTyVarEnv inst_tyvars (
 350         addErrCtxt (methodCtxt sel_id)                  $
 351         getLIE                                          $
 352         tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive
 353      )                                                  `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
 354
 355         -- Now do context reduction.   We simplify wrt both the local tyvars
 356         -- and the ones of the class/instance decl, so that there is
 357         -- no problem with
 358         --      class C a where
 359         --        op :: Eq a => a -> b -> a
 360         --
 361         -- We do this for each method independently to localise error messages
 362
 363      addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))       $
 364      newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig)      `thenM` \ meth_dicts ->
 365      let
 366         meth_tvs   = sig_tvs meth_sig
 367         all_tyvars = meth_tvs ++ inst_tyvars
 368         all_insts  = avail_insts ++ meth_dicts
 369      in
 370      tcSimplifyCheck
 371          (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
 372          all_tyvars all_insts meth_lie          `thenM` \ lie_binds ->
 373
 374      checkSigTyVars all_tyvars                  `thenM_`
 375
 376      let
 377         sel_name = idName sel_id
 378         inline_prags  = [ (is_inl, phase)
 379                         | L _ (InlineSig is_inl (L _ name) phase) <- prags,
 380                           name == sel_name ]
 381         spec_prags = [ prag
 382                      | prag@(L _ (SpecSig (L _ name) _)) <- prags,
 383                        name == sel_name]
 384
 385                 -- Attach inline pragmas as appropriate
 386         (final_meth_id, inlines)
 387            | ((is_inline, phase) : _) <- inline_prags
 388            = (meth_id `setInlinePragma` phase,
 389               if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
 390            | otherwise
 391            = (meth_id, emptyNameSet)
 392
 393         [(_,_,local_meth_id)] = mono_bind_infos
 394         poly_meth_bind = noLoc $ AbsBinds meth_tvs
 395                                   (map instToId meth_dicts)
 396                                   [(meth_tvs, final_meth_id, local_meth_id)]
 397                                   inlines
 398                                   (lie_binds `unionBags` meth_bind)
 399
 400      in
 401         -- Deal with specialisation pragmas
 402         -- The sel_name is what appears in the pragma
 403      tcExtendIdEnv2 [(sel_name, final_meth_id)] (
 404         getLIE (tcSpecSigs spec_prags)                  `thenM` \ (spec_binds1, prag_lie) ->
 405
 406              -- The prag_lie for a SPECIALISE pragma will mention the function itself,
 407              -- so we have to simplify them away right now lest they float outwards!
 408         bindInstsOfLocalFuns prag_lie [final_meth_id]   `thenM` \ spec_binds2 ->
 409         returnM (spec_binds1 `unionBags` spec_binds2)
 410      )                                                  `thenM` \ spec_binds ->
 411
 412      returnM (poly_meth_bind `consBag` spec_binds)
 413
 414
 415 mkMethodBind :: InstOrigin
 416              -> Class -> [TcType]       -- Class and instance types
 417              -> LHsBinds Name   -- Method binding (pick the right one from in here)
 418              -> ClassOpItem
 419              -> TcM (Maybe Inst,                -- Method inst
 420                      MethodSpec)
 421 -- Find the binding for the specified method, or make
 422 -- up a suitable default method if it isn't there
 423
 424 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
 425   = mkMethId origin clas sel_id inst_tys                `thenM` \ (mb_inst, meth_id) ->
 426     let
 427         meth_name  = idName meth_id
 428     in
 429         -- Figure out what method binding to use
 430         -- If the user suppplied one, use it, else construct a default one
 431     getSrcSpanM                                 `thenM` \ loc ->
 432     (case find_bind (idName sel_id) meth_name meth_binds of
 433         Just user_bind -> returnM user_bind
 434         Nothing        ->
 435            mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
 436                 -- Not infix decl
 437            returnM (noLoc $ FunBind (noLoc meth_name) False
 438                                     (mkMatchGroup [mkSimpleMatch [] rhs]))
 439     )                                           `thenM` \ meth_bind ->
 440
 441     returnM (mb_inst, (sel_id, meth_id, meth_bind))
 442
 443 mkMethId :: InstOrigin -> Class
 444          -> Id -> [TcType]      -- Selector, and instance types
 445          -> TcM (Maybe Inst, Id)
 446
 447 -- mkMethId instantiates the selector Id at the specified types
 448 mkMethId origin clas sel_id inst_tys
 449   = let
 450         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 451         rho_ty       = ASSERT( length tyvars == length inst_tys )
 452                        substTyWith tyvars inst_tys rho
 453         (preds,tau)  = tcSplitPhiTy rho_ty
 454         first_pred   = head preds
 455     in
 456         -- The first predicate should be of form (C a b)
 457         -- where C is the class in question
 458     ASSERT( not (null preds) &&
 459             case getClassPredTys_maybe first_pred of
 460                 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
 461     )
 462     if isSingleton preds then
 463         -- If it's the only one, make a 'method'
 464         getInstLoc origin                               `thenM` \ inst_loc ->
 465         newMethod inst_loc sel_id inst_tys preds tau    `thenM` \ meth_inst ->
 466         returnM (Just meth_inst, instToId meth_inst)
 467     else
 468         -- If it's not the only one we need to be careful
 469         -- For example, given 'op' defined thus:
 470         --      class Foo a where
 471         --        op :: (?x :: String) => a -> a
 472         -- (mkMethId op T) should return an Inst with type
 473         --      (?x :: String) => T -> T
 474         -- That is, the class-op's context is still there.
 475         -- BUT: it can't be a Method any more, because it breaks
 476         --      INVARIANT 2 of methods.  (See the data decl for Inst.)
 477         newUnique                       `thenM` \ uniq ->
 478         getSrcSpanM                     `thenM` \ loc ->
 479         let
 480             real_tau = mkPhiTy (tail preds) tau
 481             meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau
 482                         (srcSpanStart loc) --TODO
 483         in
 484         returnM (Nothing, meth_id)
 485
 486      -- The user didn't supply a method binding,
 487      -- so we have to make up a default binding
 488      -- The RHS of a default method depends on the default-method info
 489 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
 490   =  -- An polymorphic default method
 491     lookupImportedName (mkDefMethRdrName sel_id)        `thenM` \ dm_name ->
 492         -- Might not be imported, but will be an OrigName
 493     traceRn (text "mkDefMeth" <+> ppr dm_name)          `thenM_`
 494     returnM (nlHsVar dm_name)
 495
 496 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
 497   =     -- No default method
 498         -- Warn only if -fwarn-missing-methods
 499     doptM Opt_WarnMissingMethods                `thenM` \ warn ->
 500     warnTc (isInstDecl origin
 501            && warn
 502            && reportIfUnused (getOccName sel_id))
 503            (omittedMethodWarn sel_id)           `thenM_`
 504     returnM error_rhs
 505   where
 506     error_rhs  = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
 507     simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
 508                        (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
 509     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 510
 511         -- When the type is of form t1 -> t2 -> t3
 512         -- make a default method like (\ _ _ -> noMethBind "blah")
 513         -- rather than simply        (noMethBind "blah")
 514         -- Reason: if t1 or t2 are higher-ranked types we get n
 515         --         silly ambiguity messages.
 516         -- Example:     f :: (forall a. Eq a => a -> a) -> Int
 517         --              f = error "urk"
 518         -- Here, tcSub tries to force (error "urk") to have the right type,
 519         -- thus:        f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
 520         -- where 't' is fresh ty var.  This leads directly to "ambiguous t".
 521         --
 522         -- NB: technically this changes the meaning of the default-default
 523         --     method slightly, because `seq` can see the lambdas.  Oh well.
 524     (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
 525     (_,_,tau2)    = tcSplitSigmaTy tau1
 526         -- Need two splits because the  selector can have a type like
 527         --      forall a. Foo a => forall b. Eq b => ...
 528     (arg_tys, _) = tcSplitFunTys tau2
 529     wild_pats    = [nlWildPat | ty <- arg_tys]
 530
 531 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 532   =     -- A generic default method
 533         -- If the method is defined generically, we can only do the job if the
 534         -- instance declaration is for a single-parameter type class with
 535         -- a type constructor applied to type arguments in the instance decl
 536         --      (checkTc, so False provokes the error)
 537     ASSERT( isInstDecl origin ) -- We never get here from a class decl
 538     do  { checkTc (isJust maybe_tycon)
 539                   (badGenericInstance sel_id (notSimple inst_tys))
 540         ; checkTc (tyConHasGenerics tycon)
 541                   (badGenericInstance sel_id (notGeneric tycon))
 542
 543         ; dflags <- getDOpts
 544         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 545                    (vcat [ppr clas <+> ppr inst_tys,
 546                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 547
 548                 -- Rename it before returning it
 549         ; (rn_rhs, _) <- rnLExpr rhs
 550         ; returnM rn_rhs }
 551   where
 552     rhs = mkGenericRhs sel_id clas_tyvar tycon
 553
 554           -- The tycon is only used in the generic case, and in that
 555           -- case we require that the instance decl is for a single-parameter
 556           -- type class with type variable arguments:
 557           --    instance (...) => C (T a b)
 558     clas_tyvar    = head (classTyVars clas)
 559     Just tycon    = maybe_tycon
 560     maybe_tycon   = case inst_tys of
 561                         [ty] -> case tcSplitTyConApp_maybe ty of
 562                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 563                                   other                                           -> Nothing
 564                         other -> Nothing
 565
 566 isInstDecl (SigOrigin (InstSkol _)) = True
 567 isInstDecl (SigOrigin (ClsSkol _))  = False
 568 \end{code}
 569
 570
 571 \begin{code}
 572 -- The renamer just puts the selector ID as the binder in the method binding
 573 -- but we must use the method name; so we substitute it here.  Crude but simple.
 574 find_bind sel_name meth_name binds
 575   = foldlBag seqMaybe Nothing (mapBag f binds)
 576   where
 577         f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name
 578                 = Just (L loc1 (FunBind (L loc2 meth_name) fix matches))
 579         f _other = Nothing
 580 \end{code}
 581
 582
 583 %************************************************************************
 584 %*                                                                      *
 585 \subsection{Extracting generic instance declaration from class declarations}
 586 %*                                                                      *
 587 %************************************************************************
 588
 589 @getGenericInstances@ extracts the generic instance declarations from a class
 590 declaration.  For exmaple
 591
 592         class C a where
 593           op :: a -> a
 594
 595           op{ x+y } (Inl v)   = ...
 596           op{ x+y } (Inr v)   = ...
 597           op{ x*y } (v :*: w) = ...
 598           op{ 1   } Unit      = ...
 599
 600 gives rise to the instance declarations
 601
 602         instance C (x+y) where
 603           op (Inl v)   = ...
 604           op (Inr v)   = ...
 605
 606         instance C (x*y) where
 607           op (v :*: w) = ...
 608
 609         instance C 1 where
 610           op Unit      = ...
 611
 612
 613 \begin{code}
 614 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
 615 getGenericInstances class_decls
 616   = do  { gen_inst_infos <- mappM (addLocM get_generics) class_decls
 617         ; let { gen_inst_info = concat gen_inst_infos }
 618
 619         -- Return right away if there is no generic stuff
 620         ; if null gen_inst_info then returnM []
 621           else do
 622
 623         -- Otherwise print it out
 624         { dflags <- getDOpts
 625         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 626                    (vcat (map pprInstInfoDetails gen_inst_info)))
 627         ; returnM gen_inst_info }}
 628
 629 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 630   | null generic_binds
 631   = returnM [] -- The comon case: no generic default methods
 632
 633   | otherwise   -- A source class decl with generic default methods
 634   = recoverM (returnM [])                               $
 635     tcAddDeclCtxt decl                                  $
 636     tcLookupLocatedClass class_name                     `thenM` \ clas ->
 637
 638         -- Group by type, and
 639         -- make an InstInfo out of each group
 640     let
 641         groups = groupWith listToBag generic_binds
 642     in
 643     mappM (mkGenericInstance clas) groups               `thenM` \ inst_infos ->
 644
 645         -- Check that there is only one InstInfo for each type constructor
 646         -- The main way this can fail is if you write
 647         --      f {| a+b |} ... = ...
 648         --      f {| x+y |} ... = ...
 649         -- Then at this point we'll have an InstInfo for each
 650     let
 651         tc_inst_infos :: [(TyCon, InstInfo)]
 652         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 653
 654         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 655                               group `lengthExceeds` 1]
 656         get_uniq (tc,_) = getUnique tc
 657     in
 658     mappM (addErrTc . dupGenericInsts) bad_groups       `thenM_`
 659
 660         -- Check that there is an InstInfo for each generic type constructor
 661     let
 662         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 663     in
 664     checkTc (null missing) (missingGenericInstances missing)    `thenM_`
 665
 666     returnM inst_infos
 667   where
 668     generic_binds :: [(HsType Name, LHsBind Name)]
 669     generic_binds = getGenericBinds def_methods
 670
 671
 672 ---------------------------------
 673 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 674   -- Takes a group of method bindings, finds the generic ones, and returns
 675   -- them in finite map indexed by the type parameter in the definition.
 676 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 677
 678 getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty)))
 679   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 680   where
 681     wrap ms = L loc (FunBind id infixop (MatchGroup ms ty))
 682 getGenericBind _
 683   = []
 684
 685 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 686 groupWith op []          = []
 687 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 688     where
 689       vs            = map snd this
 690       (this,rest)   = partition same_t prs
 691       same_t (t',v) = t `eqPatType` t'
 692
 693 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 694 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 695
 696 eqPatType :: HsType Name -> HsType Name -> Bool
 697 -- A very simple equality function, only for
 698 -- type patterns in generic function definitions.
 699 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 700 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
 701 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
 702 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 703 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 704 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 705 eqPatType _ _ = False
 706
 707 ---------------------------------
 708 mkGenericInstance :: Class
 709                   -> (HsType Name, LHsBinds Name)
 710                   -> TcM InstInfo
 711
 712 mkGenericInstance clas (hs_ty, binds)
 713   -- Make a generic instance declaration
 714   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 715
 716   =     -- Extract the universally quantified type variables
 717         -- and wrap them as forall'd tyvars, so that kind inference
 718         -- works in the standard way
 719     let
 720         sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
 721         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 722     in
 723         -- Type-check the instance type, and check its form
 724     tcHsSigType GenPatCtxt hs_forall_ty         `thenM` \ forall_inst_ty ->
 725     let
 726         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 727     in
 728     checkTc (validGenericInstanceType inst_ty)
 729             (badGenericInstanceType binds)      `thenM_`
 730
 731         -- Make the dictionary function.
 732     getSrcSpanM                                         `thenM` \ span ->
 733     newDFunName clas [inst_ty] (srcSpanStart span)      `thenM` \ dfun_name ->
 734     let
 735         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 736         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 737     in
 738
 739     returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
 740 \end{code}
 741
 742
 743 %************************************************************************
 744 %*                                                                      *
 745                 Error messages
 746 %*                                                                      *
 747 %************************************************************************
 748
 749 \begin{code}
 750 tcAddDeclCtxt decl thing_inside
 751   = addErrCtxt ctxt thing_inside
 752   where
 753      thing = case decl of
 754                 ClassDecl {}              -> "class"
 755                 TySynonym {}              -> "type synonym"
 756                 TyData {tcdND = NewType}  -> "newtype"
 757                 TyData {tcdND = DataType} -> "data type"
 758
 759      ctxt = hsep [ptext SLIT("In the"), text thing,
 760                   ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 761
 762 defltMethCtxt clas
 763   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 764
 765 methodCtxt sel_id
 766   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 767
 768 badMethodErr clas op
 769   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 770           ptext SLIT("does not have a method"), quotes (ppr op)]
 771
 772 omittedMethodWarn sel_id
 773   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 774
 775 badGenericInstance sel_id because
 776   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 777          because]
 778
 779 notSimple inst_tys
 780   = vcat [ptext SLIT("because the instance type(s)"),
 781           nest 2 (ppr inst_tys),
 782           ptext SLIT("is not a simple type of form (T a b c)")]
 783
 784 notGeneric tycon
 785   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
 786           ptext SLIT("was not compiled with -fgenerics")]
 787
 788 badGenericInstanceType binds
 789   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 790           nest 4 (ppr binds)]
 791
 792 missingGenericInstances missing
 793   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 794
 795 dupGenericInsts tc_inst_infos
 796   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 797           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 798           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 799     ]
 800   where
 801     ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
 802
 803 mixedGenericErr op
 804   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 805 \end{code}