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