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