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