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