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 ( tcClassDecl1, tcClassDecls2,
   8                     MethodSpec, tcMethodBind, mkMethodBind, badMethodErr
   9                   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn            ( TyClDecl(..), Sig(..), MonoBinds(..),
  14                           HsExpr(..), HsLit(..), Pat(WildPat),
  15                           mkSimpleMatch, andMonoBinds, andMonoBindList,
  16                           isClassOpSig, isPragSig,
  17                           placeHolderType
  18                         )
  19 import BasicTypes       ( RecFlag(..), StrictnessMark(..) )
  20 import RnHsSyn          ( RenamedTyClDecl, RenamedSig,
  21                           RenamedClassOpSig, RenamedMonoBinds,
  22                           maybeGenericMatch
  23                         )
  24 import RnEnv            ( lookupSysName )
  25 import TcHsSyn          ( TcMonoBinds )
  26
  27 import Inst             ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
  28 import TcEnv            ( TyThingDetails(..),
  29                           tcLookupClass, tcExtendTyVarEnv2,
  30                           tcExtendTyVarEnv
  31                         )
  32 import TcBinds          ( tcMonoBinds )
  33 import TcMonoType       ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
  34 import TcSimplify       ( tcSimplifyCheck )
  35 import TcUnify          ( checkSigTyVars, sigCtxt )
  36 import TcMType          ( tcInstTyVars )
  37 import TcType           ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
  38                           mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
  39                           tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
  40                           getClassPredTys_maybe, mkPhiTy
  41                         )
  42 import TcRnMonad
  43 import Generics         ( mkGenericRhs )
  44 import PrelInfo         ( nO_METHOD_BINDING_ERROR_ID )
  45 import Class            ( classTyVars, classBigSig, classTyCon,
  46                           Class, ClassOpItem, DefMeth (..) )
  47 import TyCon            ( tyConGenInfo )
  48 import Subst            ( substTyWith )
  49 import MkId             ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
  50 import DataCon          ( mkDataCon )
  51 import Id               ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
  52 import Name             ( Name, NamedThing(..) )
  53 import NameEnv          ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
  54 import NameSet          ( emptyNameSet, unitNameSet )
  55 import OccName          ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
  56                           mkSuperDictSelOcc, reportIfUnused )
  57 import Outputable
  58 import Var              ( TyVar )
  59 import CmdLineOpts
  60 import UnicodeUtil      ( stringToUtf8 )
  61 import ErrUtils         ( dumpIfSet )
  62 import Util             ( count, lengthIs, isSingleton )
  63 import Maybes           ( seqMaybe )
  64 import Maybe            ( isJust )
  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 \subsection{Type checking}
 106 %*                                                                      *
 107 %************************************************************************
 108
 109 \begin{code}
 110
 111 tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
 112 tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
 113                          tcdTyVars = tyvar_names, tcdFDs = fundeps,
 114                          tcdSigs = class_sigs, tcdMeths = def_methods,
 115                          tcdLoc = src_loc})
 116   =     -- LOOK THINGS UP IN THE ENVIRONMENT
 117     tcLookupClass class_name                            `thenM` \ clas ->
 118     let
 119         tyvars     = classTyVars clas
 120         op_sigs    = filter isClassOpSig class_sigs
 121         op_names   = [n | ClassOpSig n _ _ _ <- op_sigs]
 122     in
 123     tcExtendTyVarEnv tyvars                             $
 124
 125     checkDefaultBinds clas op_names def_methods   `thenM` \ mb_dm_env ->
 126
 127         -- CHECK THE CONTEXT
 128         -- The renamer has already checked that the context mentions
 129         -- only the type variable of the class decl.
 130         -- Context is already kind-checked
 131     tcHsTheta context                                   `thenM` \ sc_theta ->
 132
 133         -- CHECK THE CLASS SIGNATURES,
 134     mappM (tcClassSig clas tyvars mb_dm_env) op_sigs    `thenM` \ sig_stuff ->
 135
 136         -- MAKE THE CLASS DETAILS
 137     lookupSysName class_name   mkClassDataConOcc        `thenM` \ datacon_name ->
 138     lookupSysName datacon_name mkWorkerOcc              `thenM` \ datacon_wkr_name ->
 139     mapM (lookupSysName class_name . mkSuperDictSelOcc)
 140          [1..length context]                            `thenM` \ sc_sel_names ->
 141       -- We number off the superclass selectors, 1, 2, 3 etc so that we
 142       -- can construct names for the selectors.  Thus
 143       --      class (C a, C b) => D a b where ...
 144       -- gives superclass selectors
 145       --      D_sc1, D_sc2
 146       -- (We used to call them D_C, but now we can have two different
 147       --  superclasses both called C!)
 148     lookupSysName class_name mkClassTyConOcc    `thenM` \ tycon_name ->
 149     let
 150         (op_tys, op_items) = unzip sig_stuff
 151         sc_tys             = mkPredTys sc_theta
 152         dict_component_tys = sc_tys ++ op_tys
 153         sc_sel_ids         = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
 154
 155         dict_con = mkDataCon datacon_name
 156                              [NotMarkedStrict | _ <- dict_component_tys]
 157                              [{- No labelled fields -}]
 158                              tyvars
 159                              [{-No context-}]
 160                              [{-No existential tyvars-}] [{-Or context-}]
 161                              dict_component_tys
 162                              (classTyCon clas)
 163                              dict_con_id dict_wrap_id
 164
 165         dict_con_id  = mkDataConId datacon_wkr_name dict_con
 166         dict_wrap_id = mkDataConWrapId dict_con
 167     in
 168     returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name)
 169 \end{code}
 170
 171 \begin{code}
 172 checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds
 173                   -> TcM (Maybe (NameEnv Bool))
 174         -- The returned environment says
 175         --      x not in env => no default method
 176         --      x -> True    => generic default method
 177         --      x -> False   => polymorphic default method
 178
 179   -- Check default bindings
 180   --    a) must be for a class op for this class
 181   --    b) must be all generic or all non-generic
 182   -- and return a mapping from class-op to DefMeth info
 183
 184   -- But do all this only for source binds
 185
 186 checkDefaultBinds clas ops Nothing
 187   = returnM Nothing
 188
 189 checkDefaultBinds clas ops (Just mbs)
 190   = go mbs      `thenM` \ dm_env ->
 191     returnM (Just dm_env)
 192   where
 193     go EmptyMonoBinds = returnM emptyNameEnv
 194
 195     go (AndMonoBinds b1 b2)
 196       = go b1   `thenM` \ dm_info1 ->
 197         go b2   `thenM` \ dm_info2 ->
 198         returnM (dm_info1 `plusNameEnv` dm_info2)
 199
 200     go (FunMonoBind op _ matches loc)
 201       = addSrcLoc loc                                   $
 202
 203         -- Check that the op is from this class
 204         checkTc (op `elem` ops) (badMethodErr clas op)          `thenM_`
 205
 206         -- Check that all the defns ar generic, or none are
 207         checkTc (all_generic || none_generic) (mixedGenericErr op)      `thenM_`
 208
 209         returnM (unitNameEnv op all_generic)
 210       where
 211         n_generic    = count (isJust . maybeGenericMatch) matches
 212         none_generic = n_generic == 0
 213         all_generic  = matches `lengthIs` n_generic
 214 \end{code}
 215
 216
 217 \begin{code}
 218 tcClassSig :: Class                     -- ...ditto...
 219            -> [TyVar]                   -- The class type variable, used for error check only
 220            -> Maybe (NameEnv Bool)      -- Info about default methods;
 221                                         --      Nothing => imported class defn with no method binds
 222            -> RenamedClassOpSig
 223            -> TcM (Type,                -- Type of the method
 224                      ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
 225
 226 -- This warrants an explanation: we need to separate generic
 227 -- default methods and default methods later on in the compiler
 228 -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
 229 -- Class.DefMeth data structure.
 230
 231 tcClassSig clas clas_tyvars maybe_dm_env
 232            (ClassOpSig op_name sig_dm op_ty src_loc)
 233   = addSrcLoc src_loc $
 234
 235         -- Check the type signature.  NB that the envt *already has*
 236         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 237     tcHsType op_ty                      `thenM` \ local_ty ->
 238
 239     let
 240         theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
 241
 242         -- Build the selector id and default method id
 243         sel_id = mkDictSelId op_name clas
 244         DefMeth dm_name = sig_dm
 245
 246         dm_info = case maybe_dm_env of
 247                     Nothing     -> sig_dm
 248                     Just dm_env -> mk_src_dm_info dm_env
 249
 250         mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
 251                                    Nothing    -> NoDefMeth
 252                                    Just True  -> GenDefMeth
 253                                    Just False -> DefMeth dm_name
 254     in
 255     returnM (local_ty, (sel_id, dm_info))
 256 \end{code}
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection[Default methods]{Default methods}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 The default methods for a class are each passed a dictionary for the
 266 class, so that they get access to the other methods at the same type.
 267 So, given the class decl
 268 \begin{verbatim}
 269 class Foo a where
 270         op1 :: a -> Bool
 271         op2 :: Ord b => a -> b -> b -> b
 272
 273         op1 x = True
 274         op2 x y z = if (op1 x) && (y < z) then y else z
 275 \end{verbatim}
 276 we get the default methods:
 277 \begin{verbatim}
 278 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 279 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 280
 281 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 282 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 283                   if (op1 a dfoo x) && (< b dord y z) then y else z
 284 \end{verbatim}
 285
 286 When we come across an instance decl, we may need to use the default
 287 methods:
 288 \begin{verbatim}
 289 instance Foo Int where {}
 290 \end{verbatim}
 291 gives
 292 \begin{verbatim}
 293 const.Foo.Int.op1 :: Int -> Bool
 294 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 295
 296 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 297 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 298
 299 dfun.Foo.Int :: Foo Int
 300 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 301 \end{verbatim}
 302 Notice that, as with method selectors above, we assume that dictionary
 303 application is curried, so there's no need to mention the Ord dictionary
 304 in const.Foo.Int.op2 (or the type variable).
 305
 306 \begin{verbatim}
 307 instance Foo a => Foo [a] where {}
 308
 309 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 310 dfun.Foo.List
 311   = /\ a -> \ dfoo_a ->
 312     let rec
 313         op1 = defm.Foo.op1 [a] dfoo_list
 314         op2 = defm.Foo.op2 [a] dfoo_list
 315         dfoo_list = (op1, op2)
 316     in
 317         dfoo_list
 318 \end{verbatim}
 319
 320 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 321 each local class decl.
 322
 323 \begin{code}
 324 tcClassDecls2 :: [RenamedTyClDecl] -> TcM (TcMonoBinds, [Id])
 325
 326 tcClassDecls2 decls
 327   = foldr combine
 328           (returnM (EmptyMonoBinds, []))
 329           [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls]
 330                 -- The 'Just' picks out source ClassDecls
 331   where
 332     combine tc1 tc2 = tc1 `thenM` \ (binds1, ids1) ->
 333                       tc2 `thenM` \ (binds2, ids2) ->
 334                       returnM (binds1 `AndMonoBinds` binds2,
 335                                ids1 ++ ids2)
 336 \end{code}
 337
 338 @tcClassDecl2@ generates bindings for polymorphic default methods
 339 (generic default methods have by now turned into instance declarations)
 340
 341 \begin{code}
 342 tcClassDecl2 :: RenamedTyClDecl         -- The class declaration
 343              -> TcM (TcMonoBinds, [Id])
 344
 345 tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs,
 346                          tcdMeths = Just default_binds, tcdLoc = src_loc})
 347   =     -- The 'Just' picks out source ClassDecls
 348     recoverM (returnM (EmptyMonoBinds, []))     $
 349     addSrcLoc src_loc                                   $
 350     tcLookupClass class_name                            `thenM` \ clas ->
 351
 352         -- We make a separate binding for each default method.
 353         -- At one time I used a single AbsBinds for all of them, thus
 354         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 355         -- But that desugars into
 356         --      ds = \d -> (..., ..., ...)
 357         --      dm1 = \d -> case ds d of (a,b,c) -> a
 358         -- And since ds is big, it doesn't get inlined, so we don't get good
 359         -- default methods.  Better to make separate AbsBinds for each
 360     let
 361         (tyvars, _, _, op_items) = classBigSig clas
 362         prags                    = filter isPragSig sigs
 363         tc_dm                    = tcDefMeth clas tyvars default_binds prags
 364     in
 365     mapAndUnzipM tc_dm op_items `thenM` \ (defm_binds, dm_ids_s) ->
 366
 367     returnM (andMonoBindList defm_binds, concat dm_ids_s)
 368
 369
 370 tcDefMeth clas tyvars binds_in prags (_, NoDefMeth)  = returnM (EmptyMonoBinds, [])
 371 tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, [])
 372         -- Generate code for polymorphic default methods only
 373         -- (Generic default methods have turned into instance decls by now.)
 374         -- This is incompatible with Hugs, which expects a polymorphic
 375         -- default method for every class op, regardless of whether or not
 376         -- the programmer supplied an explicit default decl for the class.
 377         -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 378
 379 tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
 380   = tcInstTyVars ClsTv tyvars           `thenM` \ (clas_tyvars, inst_tys, _) ->
 381     let
 382         dm_ty = idType sel_id   -- Same as dict selector!
 383           -- The default method's type should really come from the
 384           -- iface file, since it could be usage-generalised, but this
 385           -- requires altering the mess of knots in TcModule and I'm
 386           -- too scared to do that.  Instead, I have disabled generalisation
 387           -- of types of default methods (and dict funs) by annotating them
 388           -- TyGenNever (in MkId).  Ugh!  KSW 1999-09.
 389
 390         theta       = [mkClassPred clas inst_tys]
 391         local_dm_id = mkDefaultMethodId dm_name dm_ty
 392         xtve        = tyvars `zip` clas_tyvars
 393     in
 394     newDicts origin theta                               `thenM` \ [this_dict] ->
 395
 396     mkMethodBind origin clas inst_tys binds_in op_item  `thenM` \ (_, meth_info) ->
 397     getLIE (tcMethodBind xtve clas_tyvars theta
 398                          [this_dict] prags meth_info)   `thenM` \ (defm_bind, insts_needed) ->
 399
 400     addErrCtxt (defltMethCtxt clas) $
 401
 402         -- Check the context
 403     tcSimplifyCheck
 404         (ptext SLIT("class") <+> ppr clas)
 405         clas_tyvars
 406         [this_dict]
 407         insts_needed                    `thenM` \ dict_binds ->
 408
 409         -- Simplification can do unification
 410     checkSigTyVars clas_tyvars          `thenM` \ clas_tyvars' ->
 411
 412     let
 413         (_,dm_inst_id,_) = meth_info
 414         full_bind = AbsBinds
 415                     clas_tyvars'
 416                     [instToId this_dict]
 417                     [(clas_tyvars', local_dm_id, dm_inst_id)]
 418                     emptyNameSet        -- No inlines (yet)
 419                     (dict_binds `andMonoBinds` defm_bind)
 420     in
 421     returnM (full_bind, [local_dm_id])
 422   where
 423     origin = ClassDeclOrigin
 424 \end{code}
 425
 426
 427
 428 %************************************************************************
 429 %*                                                                      *
 430 \subsection{Typechecking a method}
 431 %*                                                                      *
 432 %************************************************************************
 433
 434 @tcMethodBind@ is used to type-check both default-method and
 435 instance-decl method declarations.  We must type-check methods one at a
 436 time, because their signatures may have different contexts and
 437 tyvar sets.
 438
 439 \begin{code}
 440 type MethodSpec = (Id,                  -- Global selector Id
 441                    Id,                  -- Local Id (class tyvars instantiated)
 442                    RenamedMonoBinds)    -- Binding for the method
 443
 444 tcMethodBind
 445         :: [(TyVar,TcTyVar)]    -- Bindings for type environment
 446         -> [TcTyVar]            -- Instantiated type variables for the
 447                                 --      enclosing class/instance decl.
 448                                 --      They'll be signature tyvars, and we
 449                                 --      want to check that they don't get bound
 450                                 -- Always equal the range of the type envt
 451         -> TcThetaType          -- Available theta; it's just used for the error message
 452         -> [Inst]               -- Available from context, used to simplify constraints
 453                                 --      from the method body
 454         -> [RenamedSig]         -- Pragmas (e.g. inline pragmas)
 455         -> MethodSpec           -- Details of this method
 456         -> TcM TcMonoBinds
 457
 458 tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
 459              (sel_id, meth_id, meth_bind)
 460   =     -- Check the bindings; first adding inst_tyvars to the envt
 461         -- so that we don't quantify over them in nested places
 462     mkTcSig meth_id                             `thenM` \ meth_sig ->
 463
 464      tcExtendTyVarEnv2 xtve (
 465         addErrCtxt (methodCtxt sel_id)          $
 466         getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
 467      )                                          `thenM` \ ((meth_bind, _, _), meth_lie) ->
 468
 469         -- Now do context reduction.   We simplify wrt both the local tyvars
 470         -- and the ones of the class/instance decl, so that there is
 471         -- no problem with
 472         --      class C a where
 473         --        op :: Eq a => a -> b -> a
 474         --
 475         -- We do this for each method independently to localise error messages
 476
 477      let
 478         TySigInfo meth_id meth_tvs meth_theta _ local_meth_id _ _ = meth_sig
 479      in
 480      addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))       $
 481      newDicts SignatureOrigin meth_theta        `thenM` \ meth_dicts ->
 482      let
 483         all_tyvars = meth_tvs ++ inst_tyvars
 484         all_insts  = avail_insts ++ meth_dicts
 485      in
 486      tcSimplifyCheck
 487          (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
 488          all_tyvars all_insts meth_lie          `thenM` \ lie_binds ->
 489
 490      checkSigTyVars all_tyvars                  `thenM` \ all_tyvars' ->
 491
 492      let
 493                 -- Attach inline pragmas as appropriate
 494         (final_meth_id, inlines)
 495            | (InlineSig inl _ phase _ : _) <- filter is_inline prags
 496            = (meth_id `setInlinePragma` phase,
 497               if inl then unitNameSet (idName meth_id) else emptyNameSet)
 498            | otherwise
 499            = (meth_id, emptyNameSet)
 500
 501         is_inline (InlineSig _ name _ _) = name == idName sel_id
 502         is_inline other                  = False
 503
 504         meth_tvs'      = take (length meth_tvs) all_tyvars'
 505         poly_meth_bind = AbsBinds meth_tvs'
 506                                   (map instToId meth_dicts)
 507                                   [(meth_tvs', final_meth_id, local_meth_id)]
 508                                   inlines
 509                                   (lie_binds `andMonoBinds` meth_bind)
 510      in
 511      returnM poly_meth_bind
 512
 513
 514 mkMethodBind :: InstOrigin
 515              -> Class -> [TcType]       -- Class and instance types
 516              -> RenamedMonoBinds        -- Method binding (pick the right one from in here)
 517              -> ClassOpItem
 518              -> TcM (Maybe Inst,                -- Method inst
 519                      MethodSpec)
 520 -- Find the binding for the specified method, or make
 521 -- up a suitable default method if it isn't there
 522
 523 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
 524   = mkMethId origin clas sel_id inst_tys                `thenM` \ (mb_inst, meth_id) ->
 525     let
 526         meth_name  = idName meth_id
 527     in
 528         -- Figure out what method binding to use
 529         -- If the user suppplied one, use it, else construct a default one
 530     getSrcLocM                                  `thenM` \ loc ->
 531     (case find_bind (idName sel_id) meth_name meth_binds of
 532         Just user_bind -> returnM user_bind
 533         Nothing        -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info  `thenM` \ rhs ->
 534                           returnM (FunMonoBind meth_name False  -- Not infix decl
 535                                                [mkSimpleMatch [] rhs placeHolderType loc] loc)
 536     )                                                           `thenM` \ meth_bind ->
 537
 538     returnM (mb_inst, (sel_id, meth_id, meth_bind))
 539
 540 mkMethId :: InstOrigin -> Class
 541          -> Id -> [TcType]      -- Selector, and instance types
 542          -> TcM (Maybe Inst, Id)
 543
 544 -- mkMethId instantiates the selector Id at the specified types
 545 -- THe
 546 mkMethId origin clas sel_id inst_tys
 547   = let
 548         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 549         rho_ty       = ASSERT( length tyvars == length inst_tys )
 550                        substTyWith tyvars inst_tys rho
 551         (preds,tau)  = tcSplitPhiTy rho_ty
 552         first_pred   = head preds
 553     in
 554         -- The first predicate should be of form (C a b)
 555         -- where C is the class in question
 556     ASSERT( not (null preds) &&
 557             case getClassPredTys_maybe first_pred of
 558                 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
 559     )
 560     if isSingleton preds then
 561         -- If it's the only one, make a 'method'
 562         getInstLoc origin                               `thenM` \ inst_loc ->
 563         newMethod inst_loc sel_id inst_tys preds tau    `thenM` \ meth_inst ->
 564         returnM (Just meth_inst, instToId meth_inst)
 565     else
 566         -- If it's not the only one we need to be careful
 567         -- For example, given 'op' defined thus:
 568         --      class Foo a where
 569         --        op :: (?x :: String) => a -> a
 570         -- (mkMethId op T) should return an Inst with type
 571         --      (?x :: String) => T -> T
 572         -- That is, the class-op's context is still there.
 573         -- BUT: it can't be a Method any more, because it breaks
 574         --      INVARIANT 2 of methods.  (See the data decl for Inst.)
 575         newUnique                       `thenM` \ uniq ->
 576         getSrcLocM                      `thenM` \ loc ->
 577         let
 578             real_tau = mkPhiTy (tail preds) tau
 579             meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
 580         in
 581         returnM (Nothing, meth_id)
 582
 583      -- The user didn't supply a method binding,
 584      -- so we have to make up a default binding
 585      -- The RHS of a default method depends on the default-method info
 586 mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name)
 587   =  -- An polymorphic default method
 588     traceRn (text "mkDefMeth" <+> ppr dm_name)  `thenM_`
 589     returnM (HsVar dm_name)
 590
 591 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
 592   =     -- No default method
 593         -- Warn only if -fwarn-missing-methods
 594     doptM Opt_WarnMissingMethods                `thenM` \ warn ->
 595     warnTc (isInstDecl origin
 596            && warn
 597            && reportIfUnused (getOccName sel_id))
 598            (omittedMethodWarn sel_id)           `thenM_`
 599     returnM error_rhs
 600   where
 601     error_rhs  = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc)
 602     simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 603                        (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
 604     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 605
 606         -- When the type is of form t1 -> t2 -> t3
 607         -- make a default method like (\ _ _ -> noMethBind "blah")
 608         -- rather than simply        (noMethBind "blah")
 609         -- Reason: if t1 or t2 are higher-ranked types we get n
 610         --         silly ambiguity messages.
 611         -- Example:     f :: (forall a. Eq a => a -> a) -> Int
 612         --              f = error "urk"
 613         -- Here, tcSub tries to force (error "urk") to have the right type,
 614         -- thus:        f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
 615         -- where 't' is fresh ty var.  This leads directly to "ambiguous t".
 616         --
 617         -- NB: technically this changes the meaning of the default-default
 618         --     method slightly, because `seq` can see the lambdas.  Oh well.
 619     (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
 620     (_,_,tau2)    = tcSplitSigmaTy tau1
 621         -- Need two splits because the  selector can have a type like
 622         --      forall a. Foo a => forall b. Eq b => ...
 623     (arg_tys, _) = tcSplitFunTys tau2
 624     wild_pats    = [WildPat placeHolderType | ty <- arg_tys]
 625
 626 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 627   =     -- A generic default method
 628         -- If the method is defined generically, we can only do the job if the
 629         -- instance declaration is for a single-parameter type class with
 630         -- a type constructor applied to type arguments in the instance decl
 631         --      (checkTc, so False provokes the error)
 632      ASSERT( isInstDecl origin )        -- We never get here from a class decl
 633
 634      checkTc (isJust maybe_tycon)
 635              (badGenericInstance sel_id (notSimple inst_tys))           `thenM_`
 636      checkTc (isJust (tyConGenInfo tycon))
 637              (badGenericInstance sel_id (notGeneric tycon))             `thenM_`
 638
 639      ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)        `thenM_`
 640      returnM rhs
 641   where
 642     rhs = mkGenericRhs sel_id clas_tyvar tycon
 643
 644     stuff = vcat [ppr clas <+> ppr inst_tys,
 645                   nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
 646
 647           -- The tycon is only used in the generic case, and in that
 648           -- case we require that the instance decl is for a single-parameter
 649           -- type class with type variable arguments:
 650           --    instance (...) => C (T a b)
 651     clas_tyvar    = head (classTyVars clas)
 652     Just tycon    = maybe_tycon
 653     maybe_tycon   = case inst_tys of
 654                         [ty] -> case tcSplitTyConApp_maybe ty of
 655                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 656                                   other                                           -> Nothing
 657                         other -> Nothing
 658
 659 isInstDecl InstanceDeclOrigin = True
 660 isInstDecl ClassDeclOrigin    = False
 661 \end{code}
 662
 663
 664 \begin{code}
 665 -- The renamer just puts the selector ID as the binder in the method binding
 666 -- but we must use the method name; so we substitute it here.  Crude but simple.
 667 find_bind sel_name meth_name (FunMonoBind op_name fix matches loc)
 668     | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
 669 find_bind sel_name meth_name (AndMonoBinds b1 b2)
 670     = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2
 671 find_bind sel_name meth_name other  = Nothing   -- Default case
 672
 673  -- Find the prags for this method, and replace the
 674  -- selector name with the method name
 675 find_prags sel_name meth_name [] = []
 676 find_prags sel_name meth_name (SpecSig name ty loc : prags)
 677      | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags
 678 find_prags sel_name meth_name (InlineSig sense name phase loc : prags)
 679    | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags
 680 find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
 681 \end{code}
 682
 683
 684 Contexts and errors
 685 ~~~~~~~~~~~~~~~~~~~
 686 \begin{code}
 687 defltMethCtxt clas
 688   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 689
 690 methodCtxt sel_id
 691   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 692
 693 badMethodErr clas op
 694   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 695           ptext SLIT("does not have a method"), quotes (ppr op)]
 696
 697 omittedMethodWarn sel_id
 698   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 699
 700 badGenericInstance sel_id because
 701   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 702          because]
 703
 704 notSimple inst_tys
 705   = vcat [ptext SLIT("because the instance type(s)"),
 706           nest 2 (ppr inst_tys),
 707           ptext SLIT("is not a simple type of form (T a b c)")]
 708
 709 notGeneric tycon
 710   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
 711           ptext SLIT("was not compiled with -fgenerics")]
 712
 713 mixedGenericErr op
 714   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 715 \end{code}