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