ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcInstDcls (
  10         tcInstDecls1,
  11         tcInstDecls2,
  12         processInstBinds
  13     ) where
  14
  15
  16 import Ubiq
  17
  18 import HsSyn            ( InstDecl(..), FixityDecl, Sig(..),
  19                           SpecInstSig(..), HsBinds(..), Bind(..),
  20                           MonoBinds(..), GRHSsAndBinds, Match,
  21                           InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  22                           Stmt, Qual, ArithSeqInfo, Fake,
  23                           PolyType(..), MonoType )
  24 import RnHsSyn          ( RenamedHsBinds(..), RenamedMonoBinds(..),
  25                           RenamedInstDecl(..), RenamedFixityDecl(..),
  26                           RenamedSig(..), RenamedSpecInstSig(..),
  27                           RnName(..){-incl instance Outputable-}
  28                         )
  29 import TcHsSyn          ( TcIdOcc(..), TcHsBinds(..),
  30                           TcMonoBinds(..), TcExpr(..), tcIdType,
  31                           mkHsTyLam, mkHsTyApp,
  32                           mkHsDictLam, mkHsDictApp )
  33
  34
  35 import TcMonad          hiding ( rnMtoTcM )
  36 import GenSpecEtc       ( checkSigTyVars )
  37 import Inst             ( Inst, InstOrigin(..), InstanceMapper(..),
  38                           newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
  39 import TcBinds          ( tcPragmaSigs )
  40 import TcDeriv          ( tcDeriving )
  41 import TcEnv            ( tcLookupClass, tcTyVarScope, newLocalId )
  42 import TcGRHSs          ( tcGRHSsAndBinds )
  43 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  44 import TcKind           ( TcKind, unifyKind )
  45 import TcMatches        ( tcMatchesFun )
  46 import TcMonoType       ( tcContext, tcMonoTypeKind )
  47 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyThetas )
  48 import TcType           ( TcType(..), TcTyVar(..),
  49                           tcInstSigTyVars, tcInstType, tcInstTheta
  50                         )
  51 import Unify            ( unifyTauTy )
  52
  53
  54 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  55                           concatBag, foldBag, bagToList )
  56 import CmdLineOpts      ( opt_GlasgowExts, opt_CompilingPrelude,
  57                           opt_OmitDefaultInstanceMethods,
  58                           opt_SpecialiseOverloaded )
  59 import Class            ( GenClass, GenClassOp,
  60                           isCcallishClass, classBigSig,
  61                           classOps, classOpLocalType,
  62                           classOpTagByString
  63                           )
  64 import Id               ( GenId, idType, isDefaultMethodId_maybe )
  65 import ListSetOps       ( minusList )
  66 import Maybes           ( maybeToBool, expectJust )
  67 import Name             ( getLocalName, origName, nameOf, Name{--O only-} )
  68 import PrelVals         ( nO_EXPLICIT_METHOD_ERROR_ID )
  69 import PrelMods         ( pRELUDE )
  70 import PprType          ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
  71                           pprParendGenType
  72                         )
  73 import PprStyle
  74 import Pretty
  75 import RnUtils          ( RnEnv(..) )
  76 import TyCon            ( isSynTyCon, derivedFor )
  77 import Type             ( GenType(..),  ThetaType(..), mkTyVarTys,
  78                           splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
  79                           getTyCon_maybe, maybeBoxedPrimType
  80                         )
  81 import TyVar            ( GenTyVar, mkTyVarSet )
  82 import TysWiredIn       ( stringTy )
  83 import Unique           ( Unique )
  84 import Util             ( zipEqual, panic )
  85 \end{code}
  86
  87 Typechecking instance declarations is done in two passes. The first
  88 pass, made by @tcInstDecls1@, collects information to be used in the
  89 second pass.
  90
  91 This pre-processed info includes the as-yet-unprocessed bindings
  92 inside the instance declaration.  These are type-checked in the second
  93 pass, when the class-instance envs and GVE contain all the info from
  94 all the instance and value decls.  Indeed that's the reason we need
  95 two passes over the instance decls.
  96
  97
  98 Here is the overall algorithm.
  99 Assume that we have an instance declaration
 100
 101     instance c => k (t tvs) where b
 102
 103 \begin{enumerate}
 104 \item
 105 $LIE_c$ is the LIE for the context of class $c$
 106 \item
 107 $betas_bar$ is the free variables in the class method type, excluding the
 108    class variable
 109 \item
 110 $LIE_cop$ is the LIE constraining a particular class method
 111 \item
 112 $tau_cop$ is the tau type of a class method
 113 \item
 114 $LIE_i$ is the LIE for the context of instance $i$
 115 \item
 116 $X$ is the instance constructor tycon
 117 \item
 118 $gammas_bar$ is the set of type variables of the instance
 119 \item
 120 $LIE_iop$ is the LIE for a particular class method instance
 121 \item
 122 $tau_iop$ is the tau type for this instance of a class method
 123 \item
 124 $alpha$ is the class variable
 125 \item
 126 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 127 \item
 128 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 129 \end{enumerate}
 130
 131 ToDo: Update the list above with names actually in the code.
 132
 133 \begin{enumerate}
 134 \item
 135 First, make the LIEs for the class and instance contexts, which means
 136 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 137 and make LIElistI and LIEI.
 138 \item
 139 Then process each method in turn.
 140 \item
 141 order the instance methods according to the ordering of the class methods
 142 \item
 143 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 144 \item
 145 Create final dictionary function from bindings generated already
 146 \begin{pseudocode}
 147 df = lambda inst_tyvars
 148        lambda LIEI
 149          let Bop1
 150              Bop2
 151              ...
 152              Bopn
 153          and dbinds_super
 154               in <op1,op2,...,opn,sd1,...,sdm>
 155 \end{pseudocode}
 156 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 157 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 158 \end{enumerate}
 159
 160 \begin{code}
 161 tcInstDecls1 :: Bag RenamedInstDecl
 162              -> [RenamedSpecInstSig]
 163              -> Module                  -- module name for deriving
 164              -> RnEnv                   -- for renaming derivings
 165              -> [RenamedFixityDecl]     -- fixities for deriving
 166              -> TcM s (Bag InstInfo,
 167                        RenamedHsBinds,
 168                        PprStyle -> Pretty)
 169
 170 tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
 171   =     -- Do the ordinary instance declarations
 172     mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
 173                         `thenNF_Tc` \ inst_info_bags ->
 174     let
 175         decl_inst_info = concatBag inst_info_bags
 176     in
 177         -- Handle "derived" instances; note that we only do derivings
 178         -- for things in this module; we ignore deriving decls from
 179         -- interfaces! We pass fixities, because they may be used
 180         -- in deriving Read and Show.
 181     tcDeriving mod_name rn_env decl_inst_info fixities
 182                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 183
 184     let
 185         inst_info = deriv_inst_info `unionBags` decl_inst_info
 186     in
 187 {- LATER
 188         -- Handle specialise instance pragmas
 189     tcSpecInstSigs inst_info specinst_sigs
 190                         `thenTc` \ spec_inst_info ->
 191 -}
 192     let
 193         spec_inst_info = emptyBag       -- For now
 194
 195         full_inst_info = inst_info `unionBags` spec_inst_info
 196     in
 197     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 198
 199
 200 tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 201
 202 tcInstDecl1 mod_name
 203             (InstDecl class_name
 204                       poly_ty@(HsForAllTy tyvar_names context inst_ty)
 205                       binds
 206                       from_here inst_mod uprags pragmas src_loc)
 207   =     -- Prime error recovery, set source location
 208     recoverNF_Tc (returnNF_Tc emptyBag) $
 209     tcAddSrcLoc src_loc                 $
 210
 211         -- Look things up
 212     tcLookupClass class_name            `thenNF_Tc` \ (clas_kind, clas) ->
 213
 214     let
 215         de_rn (RnName n) = n
 216     in
 217         -- Typecheck the context and instance type
 218     tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
 219         tcContext context               `thenTc` \ theta ->
 220         tcMonoTypeKind inst_ty          `thenTc` \ (tau_kind, tau) ->
 221         unifyKind clas_kind tau_kind    `thenTc_`
 222         returnTc (tyvars, theta, tau)
 223     )                                   `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 224
 225         -- Check for respectable instance type
 226     scrutiniseInstanceType from_here clas inst_tau
 227                                         `thenTc` \ (inst_tycon,arg_tys) ->
 228
 229         -- Deal with the case where we are deriving
 230         -- and importing the same instance
 231     if (not from_here && (clas `derivedFor` inst_tycon)
 232                       && all isTyVarTy arg_tys)
 233     then
 234         if not opt_CompilingPrelude && maybeToBool inst_mod &&
 235            mod_name == expectJust "inst_mod" inst_mod
 236         then
 237                 -- Imported instance came from this module;
 238                 -- discard and derive fresh instance
 239             returnTc emptyBag
 240         else
 241                 -- Imported instance declared in another module;
 242                 -- report duplicate instance error
 243             failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
 244     else
 245
 246         -- Make the dfun id and constant-method ids
 247     mkInstanceRelatedIds from_here src_loc inst_mod pragmas
 248                          clas inst_tyvars inst_tau inst_theta uprags
 249                                         `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 250
 251     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
 252                                 dfun_theta dfun_id const_meth_ids
 253                                 binds from_here inst_mod src_loc uprags))
 254 \end{code}
 255
 256
 257 %************************************************************************
 258 %*                                                                      *
 259 \subsection{Type-checking instance declarations, pass 2}
 260 %*                                                                      *
 261 %************************************************************************
 262
 263 \begin{code}
 264 tcInstDecls2 :: Bag InstInfo
 265              -> NF_TcM s (LIE s, TcHsBinds s)
 266
 267 tcInstDecls2 inst_decls
 268   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
 269   where
 270     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 271                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 272                       returnNF_Tc (lie1 `plusLIE` lie2,
 273                                    binds1 `ThenBinds` binds2)
 274 \end{code}
 275
 276
 277 ======= New documentation starts here (Sept 92)  ==============
 278
 279 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 280 the dictionary function for this instance declaration.  For example
 281 \begin{verbatim}
 282         instance Foo a => Foo [a] where
 283                 op1 x = ...
 284                 op2 y = ...
 285 \end{verbatim}
 286 might generate something like
 287 \begin{verbatim}
 288         dfun.Foo.List dFoo_a = let op1 x = ...
 289                                    op2 y = ...
 290                                in
 291                                    Dict [op1, op2]
 292 \end{verbatim}
 293
 294 HOWEVER, if the instance decl has no context, then it returns a
 295 bigger @HsBinds@ with declarations for each method.  For example
 296 \begin{verbatim}
 297         instance Foo [a] where
 298                 op1 x = ...
 299                 op2 y = ...
 300 \end{verbatim}
 301 might produce
 302 \begin{verbatim}
 303         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 304         const.Foo.op1.List a x = ...
 305         const.Foo.op2.List a y = ...
 306 \end{verbatim}
 307 This group may be mutually recursive, because (for example) there may
 308 be no method supplied for op2 in which case we'll get
 309 \begin{verbatim}
 310         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 311 \end{verbatim}
 312 that is, the default method applied to the dictionary at this type.
 313
 314 What we actually produce in either case is:
 315
 316         AbsBinds [a] [dfun_theta_dicts]
 317                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 318                  { d = (sd1,sd2, ..., op1, op2, ...)
 319                    op1 = ...
 320                    op2 = ...
 321                  }
 322
 323 The "maybe" says that we only ask AbsBinds to make global constant methods
 324 if the dfun_theta is empty.
 325
 326
 327 For an instance declaration, say,
 328
 329         instance (C1 a, C2 b) => C (T a b) where
 330                 ...
 331
 332 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 333 function whose type is
 334
 335         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 336
 337 Notice that we pass it the superclass dictionaries at the instance type; this
 338 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 339 is the @dfun_theta@ below.
 340
 341 First comes the easy case of a non-local instance decl.
 342
 343 \begin{code}
 344 tcInstDecl2 :: InstInfo
 345             -> NF_TcM s (LIE s, TcHsBinds s)
 346
 347 tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
 348   = returnNF_Tc (emptyLIE, EmptyBinds)
 349
 350 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 351                       inst_decl_theta dfun_theta
 352                       dfun_id const_meth_ids monobinds
 353                       True{-here-} inst_mod locn uprags)
 354   =      -- Prime error recovery
 355     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds))   $
 356     tcAddSrcLoc locn                                    $
 357
 358         -- Get the class signature
 359     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 360     let
 361         (class_tyvar,
 362          super_classes, sc_sel_ids,
 363          class_ops, op_sel_ids, defm_ids) = classBigSig clas
 364     in
 365     tcInstType tenv inst_ty             `thenNF_Tc` \ inst_ty' ->
 366     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 367     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 368     let
 369         sc_theta'        = super_classes `zip` repeat inst_ty'
 370         origin           = InstanceDeclOrigin
 371         mk_method sel_id = newMethodId sel_id inst_ty' origin locn
 372     in
 373          -- Create dictionary Ids from the specified instance contexts.
 374     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 375     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 376     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 377     newDicts origin [(clas,inst_ty')]   `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 378
 379          -- Create method variables
 380     mapAndUnzipNF_Tc mk_method op_sel_ids       `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
 381
 382          -- Collect available Insts
 383     let
 384         avail_insts      -- These insts are in scope; quite a few, eh?
 385           = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
 386
 387         mk_method_expr
 388           = if opt_OmitDefaultInstanceMethods then
 389                 makeInstanceDeclNoDefaultExpr     origin meth_ids defm_ids inst_ty' clas inst_mod
 390             else
 391                 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
 392     in
 393     processInstBinds clas mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
 394                                                 `thenTc` \ (insts_needed, method_mbinds) ->
 395     let
 396         -- Create the dict and method binds
 397         dict_bind
 398             = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 399
 400         dict_and_method_binds
 401             = dict_bind `AndMonoBinds` method_mbinds
 402
 403         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 404     in
 405         -- Check the overloading constraints of the methods and superclasses
 406     tcAddErrCtxt (bindSigCtxt meth_ids) (
 407         tcSimplifyAndCheck
 408                  inst_tyvars_set'                       -- Local tyvars
 409                  avail_insts
 410                  (sc_dicts `unionBags` insts_needed)    -- Need to get defns for all these
 411     )                                    `thenTc` \ (const_lie, super_binds) ->
 412
 413         -- Check that we *could* construct the superclass dictionaries,
 414         -- even though we are *actually* going to pass the superclass dicts in;
 415         -- the check ensures that the caller will never have a problem building
 416         -- them.
 417     tcAddErrCtxt superClassSigCtxt (
 418     tcSimplifyAndCheck
 419                  inst_tyvars_set'               -- Local tyvars
 420                  inst_decl_dicts                -- The instance dictionaries available
 421                  sc_dicts                       -- The superclass dicationaries reqd
 422     )                                   `thenTc_`
 423                                                 -- Ignore the result; we're only doing
 424                                                 -- this to make sure it can be done.
 425
 426         -- Now process any SPECIALIZE pragmas for the methods
 427     let
 428         spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
 429     in
 430     tcPragmaSigs spec_sigs              `thenTc` \ (_, spec_binds, spec_lie) ->
 431     let
 432         -- Complete the binding group, adding any spec_binds
 433         inst_binds
 434           = AbsBinds
 435                  inst_tyvars'
 436                  dfun_arg_dicts_ids
 437                  ((this_dict_id, RealId dfun_id)
 438                   : (meth_ids `zip` map RealId const_meth_ids))
 439                         -- NB: const_meth_ids will often be empty
 440                  super_binds
 441                  (RecBind dict_and_method_binds)
 442
 443             `ThenBinds`
 444             spec_binds
 445     in
 446
 447     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 448 \end{code}
 449
 450 @mkMethodId@ manufactures an id for a local method.
 451 It's rather turgid stuff, because there are two cases:
 452
 453   (a) For methods with no local polymorphism, we can make an Inst of the
 454       class-op selector function and a corresp InstId;
 455       which is good because then other methods which call
 456       this one will do so directly.
 457
 458   (b) For methods with local polymorphism, we can't do this.  For example,
 459
 460          class Foo a where
 461                 op :: (Num b) => a -> b -> a
 462
 463       Here the type of the class-op-selector is
 464
 465         forall a b. (Foo a, Num b) => a -> b -> a
 466
 467       The locally defined method at (say) type Float will have type
 468
 469         forall b. (Num b) => Float -> b -> Float
 470
 471       and the one is not an instance of the other.
 472
 473       So for these we just make a local (non-Inst) id with a suitable type.
 474
 475 How disgusting.
 476
 477 \begin{code}
 478 newMethodId sel_id inst_ty origin loc
 479   = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id)
 480         (_:meth_theta) = sel_theta      -- The local theta is all except the
 481                                         -- first element of the context
 482     in
 483        case sel_tyvars of
 484         -- Ah! a selector for a class op with no local polymorphism
 485         -- Build an Inst for this
 486         [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty]
 487
 488         -- Ho! a selector for a class op with local polymorphism.
 489         -- Just make a suitably typed local id for this
 490         (clas_tyvar:local_tyvars) ->
 491                 tcInstType [(clas_tyvar,inst_ty)]
 492                            (mkSigmaTy local_tyvars meth_theta sel_tau)
 493                                                                 `thenNF_Tc` \ method_ty ->
 494                 newLocalId (getLocalName sel_id) method_ty      `thenNF_Tc` \ meth_id ->
 495                 returnNF_Tc (emptyLIE, meth_id)
 496 \end{code}
 497
 498 The next function makes a default method which calls the global default method, at
 499 the appropriate instance type.
 500
 501 See the notes under default decls in TcClassDcl.lhs.
 502
 503 \begin{code}
 504 makeInstanceDeclDefaultMethodExpr
 505         :: InstOrigin s
 506         -> [TcIdOcc s]
 507         -> [Id]
 508         -> TcType s
 509         -> TcIdOcc s
 510         -> Int
 511         -> NF_TcM s (TcExpr s)
 512
 513 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
 514   = newDicts origin op_theta            `thenNF_Tc` \ (op_lie,op_dicts) ->
 515
 516         -- def_op_id = /\ op_tyvars -> \ op_dicts ->
 517         --                defm_id inst_ty op_tyvars this_dict op_dicts
 518     returnNF_Tc (
 519       mkHsTyLam op_tyvars (
 520       mkHsDictLam op_dicts (
 521       mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
 522                              (inst_ty :  mkTyVarTys op_tyvars))
 523                   (this_dict : op_dicts)
 524       )))
 525  where
 526     idx     = tag - 1
 527     meth_id = meth_ids !! idx
 528     defm_id = defm_ids  !! idx
 529     (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id)
 530
 531 makeInstanceDeclNoDefaultExpr
 532         :: InstOrigin s
 533         -> [TcIdOcc s]
 534         -> [Id]
 535         -> TcType s
 536         -> Class
 537         -> Maybe Module
 538         -> Int
 539         -> NF_TcM s (TcExpr s)
 540
 541 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
 542   = newDicts origin op_theta            `thenNF_Tc` \ (op_lie, op_dicts) ->
 543
 544         -- Produce a warning if the default instance method
 545         -- has been omitted when one exists in the class
 546     warnTc (not err_defm_ok)
 547            (omitDefaultMethodWarn clas_op clas_name inst_ty)
 548                                         `thenNF_Tc_`
 549     returnNF_Tc (mkHsTyLam op_tyvars (
 550                  mkHsDictLam op_dicts (
 551                  HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau])
 552                      (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
 553   where
 554     idx     = tag - 1
 555     meth_id = meth_ids  !! idx
 556     clas_op = (classOps clas) !! idx
 557     defm_id = defm_ids  !! idx
 558     (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
 559
 560     Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 561
 562     mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m }
 563
 564     error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
 565                 ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
 566                 ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
 567
 568     clas_name = nameOf (origName clas)
 569 \end{code}
 570
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsection{Processing each method}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 @processInstBinds@ returns a @MonoBinds@ which binds
 579 all the method ids (which are passed in).  It is used
 580         - both for instance decls,
 581         - and to compile the default-method declarations in a class decl.
 582
 583 Any method ids which don't have a binding have a suitable default
 584 binding created for them. The actual right-hand side used is
 585 created using a function which is passed in, because the right thing to
 586 do differs between instance and class decls.
 587
 588 \begin{code}
 589 processInstBinds
 590         :: Class
 591         -> (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
 592         -> [TcTyVar s]                     -- Tyvars for this instance decl
 593         -> LIE s                           -- available Insts
 594         -> [TcIdOcc s]                     -- Local method ids in tag order
 595                                            --   (instance tyvars are free in their types)
 596         -> RenamedMonoBinds
 597         -> TcM s (LIE s,                   -- These are required
 598                   TcMonoBinds s)
 599
 600 processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
 601   =
 602          -- Process the explicitly-given method bindings
 603     processInstBinds1 clas inst_tyvars avail_insts method_ids monobinds
 604                         `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 605
 606          -- Find the methods not handled, and make default method bindings for them.
 607     let
 608         unmentioned_tags = [1.. length method_ids] `minusList` tags
 609     in
 610     mapNF_Tc mk_default_method unmentioned_tags
 611                         `thenNF_Tc` \ default_bind_list ->
 612
 613     returnTc (insts_needed_in_methods,
 614               foldr AndMonoBinds method_binds default_bind_list)
 615   where
 616         -- From a tag construct us the passed-in function to construct
 617         -- the binding for the default method
 618     mk_default_method tag = mk_default_method_rhs tag   `thenNF_Tc` \ rhs ->
 619                             returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
 620 \end{code}
 621
 622 \begin{code}
 623 processInstBinds1
 624         :: Class
 625         -> [TcTyVar s]          -- Tyvars for this instance decl
 626         -> LIE s                -- available Insts
 627         -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
 628         -> RenamedMonoBinds
 629         -> TcM s ([Int],        -- Class-op tags accounted for
 630                   LIE s,        -- These are required
 631                   TcMonoBinds s)
 632
 633 processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds
 634   = returnTc ([], emptyLIE, EmptyMonoBinds)
 635
 636 processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
 637   = processInstBinds1 clas inst_tyvars avail_insts method_ids mb1
 638                                  `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
 639     processInstBinds1 clas inst_tyvars avail_insts method_ids mb2
 640                                  `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
 641     returnTc (op_tags1 ++ op_tags2,
 642               dicts1 `unionBags` dicts2,
 643               AndMonoBinds method_binds1 method_binds2)
 644 \end{code}
 645
 646 \begin{code}
 647 processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
 648   =
 649     -- Find what class op is being defined here.  The complication is
 650     -- that we could have a PatMonoBind or a FunMonoBind.  If the
 651     -- former, it should only bind a single variable, or else we're in
 652     -- trouble (I'm not sure what the static semantics of methods
 653     -- defined in a pattern binding with multiple patterns is!)
 654     -- Renamer has reduced us to these two cases.
 655     let
 656         (op,locn) = case mbind of
 657                       FunMonoBind op _ _ locn          -> (op, locn)
 658                       PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 659
 660         occ    = getLocalName op
 661         origin = InstanceDeclOrigin
 662     in
 663     tcAddSrcLoc locn                     $
 664
 665     -- Make a method id for the method
 666     let
 667         tag       = classOpTagByString clas occ
 668         method_id = method_ids !! (tag-1)
 669     in
 670
 671     -- The "method" might be a RealId, when processInstBinds is used by
 672     -- TcClassDcls:buildDefaultMethodBinds to make default-method bindings
 673     (case method_id of
 674         TcId id   -> returnNF_Tc (idType id)
 675         RealId id -> tcInstType [] (idType id)
 676     )           `thenNF_Tc` \ method_ty ->
 677     let
 678         (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
 679     in
 680     newDicts origin method_theta        `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 681
 682     case (method_tyvars, method_dict_ids) of
 683
 684       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 685
 686                 -- Type check the method itself
 687         tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 688         returnTc ([tag], lieIop, mbind')
 689
 690       other ->  -- It's a locally-polymorphic and/or overloaded method; UGH!
 691
 692                 -- Make a new id for (a) the local, non-overloaded method
 693                 -- and               (b) the locally-overloaded method
 694                 -- The latter is needed just so we can return an AbsBinds wrapped
 695                 -- up inside a MonoBinds.
 696
 697         newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
 698         newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
 699         let
 700             inst_method_tyvars = inst_tyvars ++ method_tyvars
 701         in
 702                 -- Typecheck the method
 703         tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 704
 705                 -- Check the overloading part of the signature.
 706                 -- Simplify everything fully, even though some
 707                 -- constraints could "really" be left to the next
 708                 -- level out. The case which forces this is
 709                 --
 710                 --      class Foo a where { op :: Bar a => a -> a }
 711                 --
 712                 -- Here we must simplify constraints on "a" to catch all
 713                 -- the Bar-ish things.
 714         tcAddErrCtxt (methodSigCtxt op method_ty) (
 715           tcSimplifyAndCheck
 716                 (mkTyVarSet inst_method_tyvars)
 717                 (method_dicts `plusLIE` avail_insts)
 718                 lieIop
 719         )                                        `thenTc` \ (f_dicts, dict_binds) ->
 720
 721         returnTc ([tag],
 722                   f_dicts,
 723                   VarMonoBind method_id
 724                          (HsLet
 725                              (AbsBinds
 726                                 method_tyvars
 727                                 method_dict_ids
 728                                 [(local_id, copy_id)]
 729                                 dict_binds
 730                                 (NonRecBind mbind'))
 731                              (HsVar copy_id)))
 732 \end{code}
 733
 734 \begin{code}
 735 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
 736              -> TcM s (TcMonoBinds s, LIE s)
 737
 738 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
 739   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
 740     returnTc (FunMonoBind meth_id inf rhs' locn, lie)
 741
 742 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
 743   -- pat is sure to be a (VarPatIn op)
 744   = tcAddErrCtxt (patMonoBindsCtxt pbind) $
 745     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
 746     unifyTauTy meth_ty rhs_ty           `thenTc_`
 747     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
 748 \end{code}
 749
 750
 751 %************************************************************************
 752 %*                                                                      *
 753 \subsection{Type-checking specialise instance pragmas}
 754 %*                                                                      *
 755 %************************************************************************
 756
 757 \begin{code}
 758 {- LATER
 759 tcSpecInstSigs :: E -> CE -> TCE
 760                -> Bag InstInfo          -- inst decls seen (declared and derived)
 761                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 762                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 763
 764 tcSpecInstSigs e ce tce inst_infos []
 765   = returnTc emptyBag
 766
 767 tcSpecInstSigs e ce tce inst_infos sigs
 768   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 769     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 770     returnTc spec_inst_infos
 771   where
 772     tc_inst_spec_sigs inst_mapper []
 773       = returnNF_Tc emptyBag
 774     tc_inst_spec_sigs inst_mapper (sig:sigs)
 775       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 776         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 777         returnNF_Tc (info_sig `unionBags` info_sigs)
 778
 779 tcSpecInstSig :: E -> CE -> TCE
 780               -> Bag InstInfo
 781               -> InstanceMapper
 782               -> RenamedSpecInstSig
 783               -> NF_TcM (Bag InstInfo)
 784
 785 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 786   = recoverTc emptyBag                  (
 787     tcAddSrcLoc src_loc                 (
 788     let
 789         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 790
 791         -- Make some new type variables, named as in the specialised instance type
 792         ty_names                          = extractMonoTyNames ???is_tyvarish_name??? ty
 793         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 794     in
 795     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 796                                 `thenTc` \ inst_ty ->
 797     let
 798         maybe_tycon = case maybeAppDataTyCon inst_ty of
 799                          Just (tc,_,_) -> Just tc
 800                          Nothing       -> Nothing
 801
 802         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 803     in
 804         -- Check that we have a local instance declaration to specialise
 805     checkMaybeTc maybe_unspec_inst
 806             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 807
 808         -- Create tvs to substitute for tmpls while simplifying the context
 809     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 810     let
 811         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 812                        _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
 813
 814         subst = case matchTy unspec_inst_ty inst_ty of
 815                      Just subst -> subst
 816                      Nothing    -> panic "tcSpecInstSig:matchTy"
 817
 818         subst_theta    = instantiateThetaTy subst unspec_theta
 819         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 820
 821         mk_spec_origin clas ty
 822           = InstanceSpecOrigin inst_mapper clas ty src_loc
 823         -- I'm VERY SUSPICIOUS ABOUT THIS
 824         -- the inst-mapper is in a knot at this point so it's no good
 825         -- looking at it in tcSimplify...
 826     in
 827     tcSimplifyThetas mk_spec_origin subst_tv_theta
 828                                 `thenTc` \ simpl_tv_theta ->
 829     let
 830         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 831
 832         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 833         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 834     in
 835     mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas
 836                          clas inst_tmpls inst_ty simpl_theta uprag
 837                                 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 838
 839     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 840     (if sw_chkr SpecialiseTrace then
 841         pprTrace "Specialised Instance: "
 842         (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
 843                           if null simpl_theta then ppNil else ppStr "=>",
 844                           ppr PprDebug clas,
 845                           pprParendGenType PprDebug inst_ty],
 846                    ppCat [ppStr "        derived from:",
 847                           if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
 848                           if null unspec_theta then ppNil else ppStr "=>",
 849                           ppr PprDebug clas,
 850                           pprParendGenType PprDebug unspec_inst_ty]])
 851     else id) (
 852
 853     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 854                                 dfun_theta dfun_id const_meth_ids
 855                                 binds True{-from here-} mod src_loc uprag))
 856     )))
 857
 858
 859 lookup_unspec_inst clas maybe_tycon inst_infos
 860   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 861         []       -> Nothing
 862         (info:_) -> Just info
 863   where
 864     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 865       = from_here && clas == inst_clas &&
 866         match_ty inst_ty && is_plain_instance inst_ty
 867
 868     match_inst_ty = case maybe_tycon of
 869                       Just tycon -> match_tycon tycon
 870                       Nothing    -> match_fun
 871
 872     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 873           Just (inst_tc,_,_) -> tycon == inst_tc
 874           Nothing            -> False
 875
 876     match_fun inst_ty = isFunType inst_ty
 877
 878
 879 is_plain_instance inst_ty
 880   = case (maybeAppDataTyCon inst_ty) of
 881       Just (_,tys,_) -> all isTyVarTemplateTy tys
 882       Nothing        -> case maybeUnpackFunTy inst_ty of
 883                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 884                           Nothing         -> error "TcInstDecls:is_plain_instance"
 885 -}
 886 \end{code}
 887
 888
 889 Checking for a decent instance type
 890 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 891 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 892 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 893
 894 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 895 flag is on, or (2)~the instance is imported (they must have been
 896 compiled elsewhere). In these cases, we let them go through anyway.
 897
 898 We can also have instances for functions: @instance Foo (a -> b) ...@.
 899
 900 \begin{code}
 901 scrutiniseInstanceType from_here clas inst_tau
 902         -- TYCON CHECK
 903   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 904   = failTc (instTypeErr inst_tau)
 905
 906         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 907   | from_here
 908   = returnTc (inst_tycon,arg_tys)
 909
 910         -- TYVARS CHECK
 911   | not (all isTyVarTy arg_tys ||
 912          not from_here         ||
 913          opt_GlasgowExts)
 914   = failTc (instTypeErr inst_tau)
 915
 916         -- DERIVING CHECK
 917         -- It is obviously illegal to have an explicit instance
 918         -- for something that we are also planning to `derive'
 919         -- Though we can have an explicit instance which is more
 920         -- specific than the derived instance
 921   | clas `derivedFor` inst_tycon
 922     && all isTyVarTy arg_tys
 923   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 924
 925   |     -- CCALL CHECK
 926         -- A user declaration of a CCallable/CReturnable instance
 927         -- must be for a "boxed primitive" type.
 928     isCcallishClass clas
 929     && not opt_CompilingPrelude         -- which allows anything
 930     && maybeToBool (maybeBoxedPrimType inst_tau)
 931   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 932
 933   | otherwise
 934   = returnTc (inst_tycon,arg_tys)
 935
 936   where
 937     (possible_tycon, arg_tys) = splitAppTy inst_tau
 938     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 939     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 940 \end{code}
 941
 942 \begin{code}
 943
 944 instTypeErr ty sty
 945   = case ty of
 946       SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
 947       TyVarTy tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
 948       other        -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
 949   where
 950     rest_of_msg = ppStr "' cannot be used as an instance type."
 951
 952 derivingWhenInstanceExistsErr clas tycon sty
 953   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 954          4 (ppStr "when an explicit instance exists")
 955
 956 derivingWhenInstanceImportedErr inst_mod clas tycon sty
 957   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 958          4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
 959   where
 960     pp_mod = case inst_mod of
 961                Nothing -> ppPStr SLIT("the standard Prelude")
 962                Just  m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"]
 963
 964 nonBoxedPrimCCallErr clas inst_ty sty
 965   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
 966          4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
 967                         ppr sty inst_ty, ppStr "'"])
 968
 969 omitDefaultMethodWarn clas_op clas_name inst_ty sty
 970   = ppCat [ppStr "Warning: Omitted default method for",
 971            ppr sty clas_op, ppStr "in instance",
 972            ppPStr clas_name, pprParendGenType sty inst_ty]
 973
 974
 975 patMonoBindsCtxt pbind sty
 976   = ppHang (ppStr "In a pattern binding:")
 977          4 (ppr sty pbind)
 978
 979 methodSigCtxt name ty sty
 980   = ppHang (ppBesides [ppStr "When matching the definition of class method `",
 981                        ppr sty name, ppStr "' to its signature :" ])
 982          4 (ppr sty ty)
 983
 984 bindSigCtxt method_ids sty
 985   = ppHang (ppStr "When checking type signatures for: ")
 986          4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
 987
 988 superClassSigCtxt sty
 989   = ppStr "When checking superclass constraints on instance declaration"
 990
 991 \end{code}