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 Outputable       ( 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         TcId method_bndr = method_id
 667         method_ty = idType method_bndr
 668         (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
 669     in
 670     newDicts origin method_theta                `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 671
 672     case (method_tyvars, method_dict_ids) of
 673
 674       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 675
 676                 -- Type check the method itself
 677         tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 678         returnTc ([tag], lieIop, mbind')
 679
 680       other ->  -- It's a locally-polymorphic and/or overloaded method; UGH!
 681
 682                 -- Make a new id for (a) the local, non-overloaded method
 683                 -- and               (b) the locally-overloaded method
 684                 -- The latter is needed just so we can return an AbsBinds wrapped
 685                 -- up inside a MonoBinds.
 686
 687         newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
 688         newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
 689         let
 690             inst_method_tyvars = inst_tyvars ++ method_tyvars
 691         in
 692                 -- Typecheck the method
 693         tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 694
 695                 -- Check the overloading part of the signature.
 696                 -- Simplify everything fully, even though some
 697                 -- constraints could "really" be left to the next
 698                 -- level out. The case which forces this is
 699                 --
 700                 --      class Foo a where { op :: Bar a => a -> a }
 701                 --
 702                 -- Here we must simplify constraints on "a" to catch all
 703                 -- the Bar-ish things.
 704         tcAddErrCtxt (methodSigCtxt op method_ty) (
 705           tcSimplifyAndCheck
 706                 (mkTyVarSet inst_method_tyvars)
 707                 (method_dicts `plusLIE` avail_insts)
 708                 lieIop
 709         )                                        `thenTc` \ (f_dicts, dict_binds) ->
 710
 711         returnTc ([tag],
 712                   f_dicts,
 713                   VarMonoBind method_id
 714                          (HsLet
 715                              (AbsBinds
 716                                 method_tyvars
 717                                 method_dict_ids
 718                                 [(local_id, copy_id)]
 719                                 dict_binds
 720                                 (NonRecBind mbind'))
 721                              (HsVar copy_id)))
 722 \end{code}
 723
 724 \begin{code}
 725 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
 726              -> TcM s (TcMonoBinds s, LIE s)
 727
 728 tcMethodBind meth_id meth_ty (FunMonoBind name matches locn)
 729   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
 730     returnTc (FunMonoBind meth_id rhs' locn, lie)
 731
 732 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
 733   -- pat is sure to be a (VarPatIn op)
 734   = tcAddErrCtxt (patMonoBindsCtxt pbind) $
 735     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
 736     unifyTauTy meth_ty rhs_ty           `thenTc_`
 737     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743 \subsection{Type-checking specialise instance pragmas}
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 \begin{code}
 748 {- LATER
 749 tcSpecInstSigs :: E -> CE -> TCE
 750                -> Bag InstInfo          -- inst decls seen (declared and derived)
 751                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 752                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 753
 754 tcSpecInstSigs e ce tce inst_infos []
 755   = returnTc emptyBag
 756
 757 tcSpecInstSigs e ce tce inst_infos sigs
 758   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 759     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 760     returnTc spec_inst_infos
 761   where
 762     tc_inst_spec_sigs inst_mapper []
 763       = returnNF_Tc emptyBag
 764     tc_inst_spec_sigs inst_mapper (sig:sigs)
 765       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 766         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 767         returnNF_Tc (info_sig `unionBags` info_sigs)
 768
 769 tcSpecInstSig :: E -> CE -> TCE
 770               -> Bag InstInfo
 771               -> InstanceMapper
 772               -> RenamedSpecInstSig
 773               -> NF_TcM (Bag InstInfo)
 774
 775 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 776   = recoverTc emptyBag                  (
 777     tcAddSrcLoc src_loc                 (
 778     let
 779         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 780
 781         -- Make some new type variables, named as in the specialised instance type
 782         ty_names                          = extractMonoTyNames (==) ty
 783         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 784     in
 785     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 786                                 `thenTc` \ inst_ty ->
 787     let
 788         maybe_tycon = case maybeAppDataTyCon inst_ty of
 789                          Just (tc,_,_) -> Just tc
 790                          Nothing       -> Nothing
 791
 792         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 793     in
 794         -- Check that we have a local instance declaration to specialise
 795     checkMaybeTc maybe_unspec_inst
 796             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 797
 798         -- Create tvs to substitute for tmpls while simplifying the context
 799     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 800     let
 801         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 802                        _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
 803
 804         subst = case matchTy unspec_inst_ty inst_ty of
 805                      Just subst -> subst
 806                      Nothing    -> panic "tcSpecInstSig:matchTy"
 807
 808         subst_theta    = instantiateThetaTy subst unspec_theta
 809         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 810
 811         mk_spec_origin clas ty
 812           = InstanceSpecOrigin inst_mapper clas ty src_loc
 813     in
 814     tcSimplifyThetas mk_spec_origin subst_tv_theta
 815                                 `thenTc` \ simpl_tv_theta ->
 816     let
 817         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 818
 819         tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys
 820         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 821     in
 822     mkInstanceRelatedIds e True{-from here-} mod NoInstancePragmas src_loc
 823                          clas inst_tmpls inst_ty simpl_theta uprag
 824                                 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 825
 826     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 827     (if sw_chkr SpecialiseTrace then
 828         pprTrace "Specialised Instance: "
 829         (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
 830                           if null simpl_theta then ppNil else ppStr "=>",
 831                           ppr PprDebug clas,
 832                           pprParendGenType PprDebug inst_ty],
 833                    ppCat [ppStr "        derived from:",
 834                           if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
 835                           if null unspec_theta then ppNil else ppStr "=>",
 836                           ppr PprDebug clas,
 837                           pprParendGenType PprDebug unspec_inst_ty]])
 838     else id) (
 839
 840     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 841                                 dfun_theta dfun_id const_meth_ids
 842                                 binds True{-from here-} mod src_loc uprag))
 843     )))
 844
 845
 846 lookup_unspec_inst clas maybe_tycon inst_infos
 847   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 848         []       -> Nothing
 849         (info:_) -> Just info
 850   where
 851     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 852       = from_here && clas == inst_clas &&
 853         match_ty inst_ty && is_plain_instance inst_ty
 854
 855     match_inst_ty = case maybe_tycon of
 856                       Just tycon -> match_tycon tycon
 857                       Nothing    -> match_fun
 858
 859     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 860           Just (inst_tc,_,_) -> tycon == inst_tc
 861           Nothing            -> False
 862
 863     match_fun inst_ty = isFunType inst_ty
 864
 865
 866 is_plain_instance inst_ty
 867   = case (maybeAppDataTyCon inst_ty) of
 868       Just (_,tys,_) -> all isTyVarTemplateTy tys
 869       Nothing        -> case maybeUnpackFunTy inst_ty of
 870                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 871                           Nothing         -> error "TcInstDecls:is_plain_instance"
 872 -}
 873 \end{code}
 874
 875
 876 Checking for a decent instance type
 877 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 878 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 879 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 880
 881 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 882 flag is on, or (2)~the instance is imported (they must have been
 883 compiled elsewhere). In these cases, we let them go through anyway.
 884
 885 We can also have instances for functions: @instance Foo (a -> b) ...@.
 886
 887 \begin{code}
 888 scrutiniseInstanceType from_here clas inst_tau
 889         -- TYCON CHECK
 890   | not (maybeToBool inst_tycon_maybe)
 891   = failTc (instTypeErr inst_tau)
 892
 893         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 894   | from_here
 895   = returnTc (inst_tycon,arg_tys)
 896
 897         -- TYVARS CHECK
 898   | not (all isTyVarTy arg_tys ||
 899          not from_here         ||
 900          opt_GlasgowExts)
 901   = failTc (instTypeErr inst_tau)
 902
 903         -- DERIVING CHECK
 904         -- It is obviously illegal to have an explicit instance
 905         -- for something that we are also planning to `derive'
 906         -- Though we can have an explicit instance which is more
 907         -- specific than the derived instance
 908   | clas `derivedFor` inst_tycon
 909     && all isTyVarTy arg_tys
 910   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 911
 912   |     -- CCALL CHECK
 913         -- A user declaration of a _CCallable/_CReturnable instance
 914         -- must be for a "boxed primitive" type.
 915     isCcallishClass clas
 916     && not opt_CompilingPrelude         -- which allows anything
 917     && maybeToBool (maybeBoxedPrimType inst_tau)
 918   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 919
 920   | otherwise
 921   = returnTc (inst_tycon,arg_tys)
 922
 923   where
 924     (possible_tycon, arg_tys) = splitAppTy inst_tau
 925     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 926     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 927 \end{code}
 928
 929 \begin{code}
 930
 931 instTypeErr ty sty
 932   = case ty of
 933       SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
 934       TyVarTy tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
 935       other        -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
 936   where
 937     rest_of_msg = ppStr "' cannot be used as an instance type."
 938
 939 derivingWhenInstanceExistsErr clas tycon sty
 940   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 941          4 (ppStr "when an explicit instance exists")
 942
 943 derivingWhenInstanceImportedErr inst_mod clas tycon sty
 944   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 945          4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
 946   where
 947     pp_mod = case inst_mod of
 948                Nothing -> ppPStr SLIT("the standard Prelude")
 949                Just  m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"]
 950
 951 nonBoxedPrimCCallErr clas inst_ty sty
 952   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
 953          4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
 954                         ppr sty inst_ty, ppStr "'"])
 955
 956 omitDefaultMethodWarn clas_op clas_name inst_ty sty
 957   = ppCat [ppStr "Warning: Omitted default method for",
 958            ppr sty clas_op, ppStr "in instance",
 959            ppPStr clas_name, pprParendGenType sty inst_ty]
 960
 961
 962 patMonoBindsCtxt pbind sty
 963   = ppHang (ppStr "In a pattern binding:")
 964          4 (ppr sty pbind)
 965
 966 methodSigCtxt name ty sty
 967   = ppHang (ppBesides [ppStr "When matching the definition of class method `",
 968                        ppr sty name, ppStr "' to its signature :" ])
 969          4 (ppr sty ty)
 970
 971 bindSigCtxt method_ids sty
 972   = ppHang (ppStr "When checking type signatures for: ")
 973          4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
 974
 975 superClassSigCtxt sty
 976   = ppStr "When checking superclass constraints on instance declaration"
 977
 978 \end{code}