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