ghc/compiler/typecheck/TcClassDcl.lhs

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