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 IMP_Ubiq()
  17
  18 import HsSyn            ( InstDecl(..), FixityDecl, Sig(..),
  19                           SpecInstSig(..), HsBinds(..), Bind(..),
  20                           MonoBinds(..), GRHSsAndBinds, Match,
  21                           InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  22                           Stmt, Qualifier, ArithSeqInfo, Fake,
  23                           PolyType(..), MonoType )
  24 import RnHsSyn          ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
  25                           RenamedInstDecl(..), RenamedFixityDecl(..),
  26                           RenamedSig(..), RenamedSpecInstSig(..),
  27                           RnName(..){-incl instance Outputable-}
  28                         )
  29 import TcHsSyn          ( TcIdOcc(..), SYN_IE(TcHsBinds),
  30                           SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
  31                           mkHsTyLam, mkHsTyApp,
  32                           mkHsDictLam, mkHsDictApp )
  33
  34
  35 import TcMonad          hiding ( rnMtoTcM )
  36 import GenSpecEtc       ( checkSigTyVars )
  37 import Inst             ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
  38                           newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
  39 import TcBinds          ( tcPragmaSigs )
  40 import TcDeriv          ( tcDeriving )
  41 import TcEnv            ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
  42 import SpecEnv          ( SpecEnv )
  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           ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
  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_CompilingGhcInternals,
  58                           opt_OmitDefaultInstanceMethods,
  59                           opt_SpecialiseOverloaded
  60                         )
  61 import Class            ( GenClass, GenClassOp,
  62                           isCcallishClass, classBigSig,
  63                           classOps, classOpLocalType,
  64                           classOpTagByString_maybe
  65                           )
  66 import Id               ( GenId, idType, isDefaultMethodId_maybe )
  67 import ListSetOps       ( minusList )
  68 import Maybes           ( maybeToBool, expectJust )
  69 import Name             ( getLocalName, origName, nameOf, Name{--O only-} )
  70 import PrelVals         ( nO_EXPLICIT_METHOD_ERROR_ID )
  71 import PrelMods         ( pRELUDE )
  72 import PprType          ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
  73                           pprParendGenType
  74                         )
  75 import PprStyle
  76 import Pretty
  77 import RnUtils          ( SYN_IE(RnEnv) )
  78 import TyCon            ( isSynTyCon, derivedFor )
  79 import Type             ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
  80                           splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
  81                           getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
  82                         )
  83 import TyVar            ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
  84 import TysWiredIn       ( stringTy )
  85 import Unique           ( Unique )
  86 import Util             ( zipEqual, panic )
  87 \end{code}
  88
  89 Typechecking instance declarations is done in two passes. The first
  90 pass, made by @tcInstDecls1@, collects information to be used in the
  91 second pass.
  92
  93 This pre-processed info includes the as-yet-unprocessed bindings
  94 inside the instance declaration.  These are type-checked in the second
  95 pass, when the class-instance envs and GVE contain all the info from
  96 all the instance and value decls.  Indeed that's the reason we need
  97 two passes over the instance decls.
  98
  99
 100 Here is the overall algorithm.
 101 Assume that we have an instance declaration
 102
 103     instance c => k (t tvs) where b
 104
 105 \begin{enumerate}
 106 \item
 107 $LIE_c$ is the LIE for the context of class $c$
 108 \item
 109 $betas_bar$ is the free variables in the class method type, excluding the
 110    class variable
 111 \item
 112 $LIE_cop$ is the LIE constraining a particular class method
 113 \item
 114 $tau_cop$ is the tau type of a class method
 115 \item
 116 $LIE_i$ is the LIE for the context of instance $i$
 117 \item
 118 $X$ is the instance constructor tycon
 119 \item
 120 $gammas_bar$ is the set of type variables of the instance
 121 \item
 122 $LIE_iop$ is the LIE for a particular class method instance
 123 \item
 124 $tau_iop$ is the tau type for this instance of a class method
 125 \item
 126 $alpha$ is the class variable
 127 \item
 128 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 129 \item
 130 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 131 \end{enumerate}
 132
 133 ToDo: Update the list above with names actually in the code.
 134
 135 \begin{enumerate}
 136 \item
 137 First, make the LIEs for the class and instance contexts, which means
 138 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 139 and make LIElistI and LIEI.
 140 \item
 141 Then process each method in turn.
 142 \item
 143 order the instance methods according to the ordering of the class methods
 144 \item
 145 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 146 \item
 147 Create final dictionary function from bindings generated already
 148 \begin{pseudocode}
 149 df = lambda inst_tyvars
 150        lambda LIEI
 151          let Bop1
 152              Bop2
 153              ...
 154              Bopn
 155          and dbinds_super
 156               in <op1,op2,...,opn,sd1,...,sdm>
 157 \end{pseudocode}
 158 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 159 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 160 \end{enumerate}
 161
 162 \begin{code}
 163 tcInstDecls1 :: Bag RenamedInstDecl
 164              -> [RenamedSpecInstSig]
 165              -> Module                  -- module name for deriving
 166              -> RnEnv                   -- for renaming derivings
 167              -> [RenamedFixityDecl]     -- fixities for deriving
 168              -> TcM s (Bag InstInfo,
 169                        RenamedHsBinds,
 170                        PprStyle -> Pretty)
 171
 172 tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
 173   =     -- Do the ordinary instance declarations
 174     mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
 175                         `thenNF_Tc` \ inst_info_bags ->
 176     let
 177         decl_inst_info = concatBag inst_info_bags
 178     in
 179         -- Handle "derived" instances; note that we only do derivings
 180         -- for things in this module; we ignore deriving decls from
 181         -- interfaces! We pass fixities, because they may be used
 182         -- in deriving Read and Show.
 183     tcDeriving mod_name rn_env decl_inst_info fixities
 184                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 185
 186     let
 187         inst_info = deriv_inst_info `unionBags` decl_inst_info
 188     in
 189 {- LATER
 190         -- Handle specialise instance pragmas
 191     tcSpecInstSigs inst_info specinst_sigs
 192                         `thenTc` \ spec_inst_info ->
 193 -}
 194     let
 195         spec_inst_info = emptyBag       -- For now
 196
 197         full_inst_info = inst_info `unionBags` spec_inst_info
 198     in
 199     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 200
 201
 202 tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 203
 204 tcInstDecl1 mod_name
 205             (InstDecl class_name
 206                       poly_ty@(HsForAllTy tyvar_names context inst_ty)
 207                       binds
 208                       from_here inst_mod uprags pragmas src_loc)
 209   =     -- Prime error recovery, set source location
 210     recoverNF_Tc (returnNF_Tc emptyBag) $
 211     tcAddSrcLoc src_loc                 $
 212
 213         -- Look things up
 214     tcLookupClass class_name            `thenNF_Tc` \ (clas_kind, clas) ->
 215
 216     let
 217         de_rn (RnName n) = n
 218     in
 219         -- Typecheck the context and instance type
 220     tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
 221         tcContext context               `thenTc` \ theta ->
 222         tcMonoTypeKind inst_ty          `thenTc` \ (tau_kind, tau) ->
 223         unifyKind clas_kind tau_kind    `thenTc_`
 224         returnTc (tyvars, theta, tau)
 225     )                                   `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 226
 227         -- Check for respectable instance type
 228     scrutiniseInstanceType from_here clas inst_tau
 229                                         `thenTc` \ (inst_tycon,arg_tys) ->
 230
 231         -- Deal with the case where we are deriving
 232         -- and importing the same instance
 233     if (not from_here && (clas `derivedFor` inst_tycon)
 234                       && all isTyVarTy arg_tys)
 235     then
 236         if mod_name == 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 = newMethod origin (RealId sel_id) [inst_ty']
 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         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 386
 387         avail_insts      -- These insts are in scope; quite a few, eh?
 388           = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
 389
 390         mk_method_expr
 391           = if opt_OmitDefaultInstanceMethods then
 392                 makeInstanceDeclNoDefaultExpr     origin meth_ids defm_ids inst_ty' clas inst_mod
 393             else
 394                 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
 395     in
 396     tcExtendGlobalTyVars inst_tyvars_set' (
 397         processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
 398     )                                   `thenTc` \ (insts_needed, method_mbinds) ->
 399     let
 400         -- Create the dict and method binds
 401         dict_bind
 402             = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 403
 404         dict_and_method_binds
 405             = dict_bind `AndMonoBinds` method_mbinds
 406
 407     in
 408         -- Check the overloading constraints of the methods and superclasses
 409     tcAddErrCtxt (bindSigCtxt meth_ids) (
 410         tcSimplifyAndCheck
 411                  inst_tyvars_set'                       -- Local tyvars
 412                  avail_insts
 413                  (sc_dicts `unionBags` insts_needed)    -- Need to get defns for all these
 414     )                                    `thenTc` \ (const_lie, super_binds) ->
 415
 416         -- Check that we *could* construct the superclass dictionaries,
 417         -- even though we are *actually* going to pass the superclass dicts in;
 418         -- the check ensures that the caller will never have a problem building
 419         -- them.
 420     tcAddErrCtxt superClassSigCtxt (
 421     tcSimplifyAndCheck
 422                  inst_tyvars_set'               -- Local tyvars
 423                  inst_decl_dicts                -- The instance dictionaries available
 424                  sc_dicts                       -- The superclass dicationaries reqd
 425     )                                   `thenTc_`
 426                                                 -- Ignore the result; we're only doing
 427                                                 -- this to make sure it can be done.
 428
 429         -- Now process any SPECIALIZE pragmas for the methods
 430     let
 431         spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
 432     in
 433     tcPragmaSigs spec_sigs              `thenTc` \ (_, spec_binds, spec_lie) ->
 434     let
 435         -- Complete the binding group, adding any spec_binds
 436         inst_binds
 437           = AbsBinds
 438                  inst_tyvars'
 439                  dfun_arg_dicts_ids
 440                  ((this_dict_id, RealId dfun_id)
 441                   : (meth_ids `zip` map RealId const_meth_ids))
 442                         -- NB: const_meth_ids will often be empty
 443                  super_binds
 444                  (RecBind dict_and_method_binds)
 445
 446             `ThenBinds`
 447             spec_binds
 448     in
 449
 450     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 451 \end{code}
 452
 453 The next function makes a default method which calls the global default method, at
 454 the appropriate instance type.
 455
 456 See the notes under default decls in TcClassDcl.lhs.
 457
 458 \begin{code}
 459 makeInstanceDeclDefaultMethodExpr
 460         :: InstOrigin s
 461         -> [TcIdOcc s]
 462         -> [Id]
 463         -> TcType s
 464         -> TcIdOcc s
 465         -> Int
 466         -> NF_TcM s (TcExpr s)
 467
 468 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
 469   =
 470         -- def_op_id = defm_id inst_ty this_dict
 471     returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
 472  where
 473     idx     = tag - 1
 474     meth_id = meth_ids !! idx
 475     defm_id = defm_ids  !! idx
 476
 477 makeInstanceDeclNoDefaultExpr
 478         :: InstOrigin s
 479         -> [TcIdOcc s]
 480         -> [Id]
 481         -> TcType s
 482         -> Class
 483         -> Module
 484         -> Int
 485         -> NF_TcM s (TcExpr s)
 486
 487 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
 488   =
 489         -- Produce a warning if the default instance method
 490         -- has been omitted when one exists in the class
 491     warnTc (not err_defm_ok)
 492            (omitDefaultMethodWarn clas_op clas_name inst_ty)
 493                                         `thenNF_Tc_`
 494     returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
 495                        (HsLitOut (HsString (_PK_ error_msg)) stringTy))
 496   where
 497     idx     = tag - 1
 498     meth_id = meth_ids  !! idx
 499     clas_op = (classOps clas) !! idx
 500     defm_id = defm_ids  !! idx
 501
 502     Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 503
 504     error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
 505                 ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
 506                 ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
 507
 508     clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
 509 \end{code}
 510
 511
 512 %************************************************************************
 513 %*                                                                      *
 514 \subsection{Processing each method}
 515 %*                                                                      *
 516 %************************************************************************
 517
 518 @processInstBinds@ returns a @MonoBinds@ which binds
 519 all the method ids (which are passed in).  It is used
 520         - both for instance decls,
 521         - and to compile the default-method declarations in a class decl.
 522
 523 Any method ids which don't have a binding have a suitable default
 524 binding created for them. The actual right-hand side used is
 525 created using a function which is passed in, because the right thing to
 526 do differs between instance and class decls.
 527
 528 \begin{code}
 529 processInstBinds
 530         :: Class
 531         -> (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
 532         -> LIE s                           -- available Insts
 533         -> [TcIdOcc s]                     -- Local method ids in tag order
 534                                            --   (instance tyvars are free in their types)
 535         -> RenamedMonoBinds
 536         -> TcM s (LIE s,                   -- These are required
 537                   TcMonoBinds s)
 538
 539 processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
 540   =
 541          -- Process the explicitly-given method bindings
 542     processInstBinds1 clas avail_insts method_ids monobinds
 543                         `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 544
 545          -- Find the methods not handled, and make default method bindings for them.
 546     let
 547         unmentioned_tags = [1.. length method_ids] `minusList` tags
 548     in
 549     mapNF_Tc mk_default_method unmentioned_tags
 550                         `thenNF_Tc` \ default_bind_list ->
 551
 552     returnTc (insts_needed_in_methods,
 553               foldr AndMonoBinds method_binds default_bind_list)
 554   where
 555         -- From a tag construct us the passed-in function to construct
 556         -- the binding for the default method
 557     mk_default_method tag = mk_default_method_rhs tag   `thenNF_Tc` \ rhs ->
 558                             returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
 559 \end{code}
 560
 561 \begin{code}
 562 processInstBinds1
 563         :: Class
 564         -> LIE s                -- available Insts
 565         -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
 566         -> RenamedMonoBinds
 567         -> TcM s ([Int],        -- Class-op tags accounted for
 568                   LIE s,        -- These are required
 569                   TcMonoBinds s)
 570
 571 processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
 572   = returnTc ([], emptyLIE, EmptyMonoBinds)
 573
 574 processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
 575   = processInstBinds1 clas avail_insts method_ids mb1
 576                                  `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
 577     processInstBinds1 clas avail_insts method_ids mb2
 578                                  `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
 579     returnTc (op_tags1 ++ op_tags2,
 580               dicts1 `unionBags` dicts2,
 581               AndMonoBinds method_binds1 method_binds2)
 582 \end{code}
 583
 584 \begin{code}
 585 processInstBinds1 clas avail_insts method_ids mbind
 586   =
 587     -- Find what class op is being defined here.  The complication is
 588     -- that we could have a PatMonoBind or a FunMonoBind.  If the
 589     -- former, it should only bind a single variable, or else we're in
 590     -- trouble (I'm not sure what the static semantics of methods
 591     -- defined in a pattern binding with multiple patterns is!)
 592     -- Renamer has reduced us to these two cases.
 593     let
 594         (op,locn) = case mbind of
 595                       FunMonoBind op _ _ locn          -> (op, locn)
 596                       PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 597
 598         occ    = getLocalName op
 599         origin = InstanceDeclOrigin
 600     in
 601     tcAddSrcLoc locn                     $
 602
 603     -- Make a method id for the method
 604     let
 605         maybe_tag  = classOpTagByString_maybe clas occ
 606         (Just tag) = maybe_tag
 607         method_id  = method_ids !! (tag-1)
 608         method_ty  = tcIdType method_id
 609     in
 610     -- check that the method mentioned is actually in the class:
 611     checkMaybeTc maybe_tag (instMethodNotInClassErr occ clas) `thenTc_`
 612
 613     tcInstTcType method_ty              `thenNF_Tc` \ (method_tyvars, method_rho) ->
 614     let
 615         (method_theta, method_tau) = splitRhoTy method_rho
 616     in
 617     newDicts origin method_theta        `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 618
 619     case (method_tyvars, method_dict_ids) of
 620
 621       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 622
 623                 -- Type check the method itself
 624         tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 625         returnTc ([tag], lieIop, mbind')
 626
 627       other ->  -- It's a locally-polymorphic and/or overloaded method; UGH!
 628
 629                 -- Make a new id for (a) the local, non-overloaded method
 630                 -- and               (b) the locally-overloaded method
 631                 -- The latter is needed just so we can return an AbsBinds wrapped
 632                 -- up inside a MonoBinds.
 633
 634
 635                 -- Make the method_tyvars into signature tyvars so they
 636                 -- won't get unified with anything.
 637         tcInstSigTyVars method_tyvars           `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
 638         unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars)        `thenTc_`
 639
 640         newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
 641         newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
 642         let
 643             sig_tyvar_set = mkTyVarSet sig_tyvars
 644         in
 645                 -- Typecheck the method
 646         tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 647
 648                 -- Check the overloading part of the signature.
 649
 650         -- =========== POSSIBLE BUT NOT DONE =================
 651                 -- Simplify everything fully, even though some
 652                 -- constraints could "really" be left to the next
 653                 -- level out. The case which forces this is
 654                 --
 655                 --      class Foo a where { op :: Bar a => a -> a }
 656                 --
 657                 -- Here we must simplify constraints on "a" to catch all
 658                 -- the Bar-ish things.
 659
 660                 -- We don't do this because it's currently illegal Haskell (not sure why),
 661                 -- and because the local type of the method would have a context at
 662                 -- the front with no for-all, which confuses the hell out of everything!
 663         -- ====================================================
 664
 665         tcAddErrCtxt (methodSigCtxt op method_ty) (
 666             checkSigTyVars
 667                 sig_tyvars method_tau                           `thenTc_`
 668
 669           tcSimplifyAndCheck
 670                 sig_tyvar_set
 671                 (method_dicts `plusLIE` avail_insts)
 672                 lieIop
 673         )                                        `thenTc` \ (f_dicts, dict_binds) ->
 674
 675
 676         returnTc ([tag],
 677                   f_dicts,
 678                   VarMonoBind method_id
 679                          (HsLet
 680                              (AbsBinds
 681                                 method_tyvars
 682                                 method_dict_ids
 683                                 [(local_id, copy_id)]
 684                                 dict_binds
 685                                 (NonRecBind mbind'))
 686                              (HsVar copy_id)))
 687 \end{code}
 688
 689 \begin{code}
 690 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
 691              -> TcM s (TcMonoBinds s, LIE s)
 692
 693 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
 694   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
 695     returnTc (FunMonoBind meth_id inf rhs' locn, lie)
 696
 697 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
 698   -- pat is sure to be a (VarPatIn op)
 699   = tcAddErrCtxt (patMonoBindsCtxt pbind) $
 700     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
 701     unifyTauTy meth_ty rhs_ty           `thenTc_`
 702     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
 703 \end{code}
 704
 705
 706 %************************************************************************
 707 %*                                                                      *
 708 \subsection{Type-checking specialise instance pragmas}
 709 %*                                                                      *
 710 %************************************************************************
 711
 712 \begin{code}
 713 {- LATER
 714 tcSpecInstSigs :: E -> CE -> TCE
 715                -> Bag InstInfo          -- inst decls seen (declared and derived)
 716                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 717                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 718
 719 tcSpecInstSigs e ce tce inst_infos []
 720   = returnTc emptyBag
 721
 722 tcSpecInstSigs e ce tce inst_infos sigs
 723   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 724     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 725     returnTc spec_inst_infos
 726   where
 727     tc_inst_spec_sigs inst_mapper []
 728       = returnNF_Tc emptyBag
 729     tc_inst_spec_sigs inst_mapper (sig:sigs)
 730       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 731         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 732         returnNF_Tc (info_sig `unionBags` info_sigs)
 733
 734 tcSpecInstSig :: E -> CE -> TCE
 735               -> Bag InstInfo
 736               -> InstanceMapper
 737               -> RenamedSpecInstSig
 738               -> NF_TcM (Bag InstInfo)
 739
 740 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 741   = recoverTc emptyBag                  (
 742     tcAddSrcLoc src_loc                 (
 743     let
 744         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 745
 746         -- Make some new type variables, named as in the specialised instance type
 747         ty_names                          = extractMonoTyNames ???is_tyvarish_name??? ty
 748         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 749     in
 750     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 751                                 `thenTc` \ inst_ty ->
 752     let
 753         maybe_tycon = case maybeAppDataTyCon inst_ty of
 754                          Just (tc,_,_) -> Just tc
 755                          Nothing       -> Nothing
 756
 757         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 758     in
 759         -- Check that we have a local instance declaration to specialise
 760     checkMaybeTc maybe_unspec_inst
 761             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 762
 763         -- Create tvs to substitute for tmpls while simplifying the context
 764     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 765     let
 766         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 767                        _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
 768
 769         subst = case matchTy unspec_inst_ty inst_ty of
 770                      Just subst -> subst
 771                      Nothing    -> panic "tcSpecInstSig:matchTy"
 772
 773         subst_theta    = instantiateThetaTy subst unspec_theta
 774         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 775
 776         mk_spec_origin clas ty
 777           = InstanceSpecOrigin inst_mapper clas ty src_loc
 778         -- I'm VERY SUSPICIOUS ABOUT THIS
 779         -- the inst-mapper is in a knot at this point so it's no good
 780         -- looking at it in tcSimplify...
 781     in
 782     tcSimplifyThetas mk_spec_origin subst_tv_theta
 783                                 `thenTc` \ simpl_tv_theta ->
 784     let
 785         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 786
 787         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 788         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 789     in
 790     mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas
 791                          clas inst_tmpls inst_ty simpl_theta uprag
 792                                 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 793
 794     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 795     (if sw_chkr SpecialiseTrace then
 796         pprTrace "Specialised Instance: "
 797         (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
 798                           if null simpl_theta then ppNil else ppStr "=>",
 799                           ppr PprDebug clas,
 800                           pprParendGenType PprDebug inst_ty],
 801                    ppCat [ppStr "        derived from:",
 802                           if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
 803                           if null unspec_theta then ppNil else ppStr "=>",
 804                           ppr PprDebug clas,
 805                           pprParendGenType PprDebug unspec_inst_ty]])
 806     else id) (
 807
 808     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 809                                 dfun_theta dfun_id const_meth_ids
 810                                 binds True{-from here-} mod src_loc uprag))
 811     )))
 812
 813
 814 lookup_unspec_inst clas maybe_tycon inst_infos
 815   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 816         []       -> Nothing
 817         (info:_) -> Just info
 818   where
 819     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 820       = from_here && clas == inst_clas &&
 821         match_ty inst_ty && is_plain_instance inst_ty
 822
 823     match_inst_ty = case maybe_tycon of
 824                       Just tycon -> match_tycon tycon
 825                       Nothing    -> match_fun
 826
 827     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 828           Just (inst_tc,_,_) -> tycon == inst_tc
 829           Nothing            -> False
 830
 831     match_fun inst_ty = isFunType inst_ty
 832
 833
 834 is_plain_instance inst_ty
 835   = case (maybeAppDataTyCon inst_ty) of
 836       Just (_,tys,_) -> all isTyVarTemplateTy tys
 837       Nothing        -> case maybeUnpackFunTy inst_ty of
 838                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 839                           Nothing         -> error "TcInstDecls:is_plain_instance"
 840 -}
 841 \end{code}
 842
 843
 844 Checking for a decent instance type
 845 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 846 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 847 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 848
 849 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 850 flag is on, or (2)~the instance is imported (they must have been
 851 compiled elsewhere). In these cases, we let them go through anyway.
 852
 853 We can also have instances for functions: @instance Foo (a -> b) ...@.
 854
 855 \begin{code}
 856 scrutiniseInstanceType from_here clas inst_tau
 857         -- TYCON CHECK
 858   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 859   = failTc (instTypeErr inst_tau)
 860
 861         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 862   | not from_here
 863   = returnTc (inst_tycon,arg_tys)
 864
 865         -- TYVARS CHECK
 866   | not (all isTyVarTy arg_tys ||
 867          opt_GlasgowExts)
 868   = failTc (instTypeErr inst_tau)
 869
 870         -- DERIVING CHECK
 871         -- It is obviously illegal to have an explicit instance
 872         -- for something that we are also planning to `derive'
 873         -- Though we can have an explicit instance which is more
 874         -- specific than the derived instance
 875   | clas `derivedFor` inst_tycon
 876     && all isTyVarTy arg_tys
 877   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 878
 879   |     -- CCALL CHECK
 880         -- A user declaration of a CCallable/CReturnable instance
 881         -- must be for a "boxed primitive" type.
 882     isCcallishClass clas
 883     && not (maybeToBool (maybeBoxedPrimType inst_tau)
 884             || opt_CompilingGhcInternals) -- this lets us get up to mischief;
 885                                      -- e.g., instance CCallable ()
 886   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 887
 888   | otherwise
 889   = returnTc (inst_tycon,arg_tys)
 890
 891   where
 892     (possible_tycon, arg_tys) = splitAppTy inst_tau
 893     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 894     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 895 \end{code}
 896
 897 \begin{code}
 898
 899 instTypeErr ty sty
 900   = case ty of
 901       SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
 902       TyVarTy tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
 903       other        -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
 904   where
 905     rest_of_msg = ppStr "' cannot be used as an instance type."
 906
 907 derivingWhenInstanceExistsErr clas tycon sty
 908   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 909          4 (ppStr "when an explicit instance exists")
 910
 911 derivingWhenInstanceImportedErr inst_mod clas tycon sty
 912   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 913          4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
 914   where
 915     pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
 916
 917 nonBoxedPrimCCallErr clas inst_ty sty
 918   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
 919          4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
 920                         ppr sty inst_ty, ppStr "'"])
 921
 922 omitDefaultMethodWarn clas_op clas_name inst_ty sty
 923   = ppCat [ppStr "Warning: Omitted default method for",
 924            ppr sty clas_op, ppStr "in instance",
 925            ppPStr clas_name, pprParendGenType sty inst_ty]
 926
 927 instMethodNotInClassErr occ clas sty
 928   = ppHang (ppStr "Instance mentions a method not in the class")
 929          4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `",
 930                        ppPStr occ, ppStr "'"])
 931
 932 patMonoBindsCtxt pbind sty
 933   = ppHang (ppStr "In a pattern binding:")
 934          4 (ppr sty pbind)
 935
 936 methodSigCtxt name ty sty
 937   = ppHang (ppBesides [ppStr "When matching the definition of class method `",
 938                        ppr sty name, ppStr "' to its signature :" ])
 939          4 (ppr sty ty)
 940
 941 bindSigCtxt method_ids sty
 942   = ppHang (ppStr "When checking type signatures for: ")
 943          4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
 944
 945 superClassSigCtxt sty
 946   = ppStr "When checking superclass constraints on instance declaration"
 947
 948 \end{code}