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