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