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