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