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          ( 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          hiding ( rnMtoTcM )
  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, tcExtendGlobalTyVars )
  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 )
  48 import TcType           ( TcType(..), TcTyVar(..), TcTyVarSet(..),
  49                           tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
  50                         )
  51 import Unify            ( unifyTauTy, unifyTauTyLists )
  52
  53
  54 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  55                           concatBag, foldBag, bagToList )
  56 import CmdLineOpts      ( opt_GlasgowExts, opt_CompilingGhcInternals,
  57                           opt_OmitDefaultInstanceMethods,
  58                           opt_SpecialiseOverloaded
  59                         )
  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          ( SYN_IE(RnEnv) )
  77 import TyCon            ( isSynTyCon, derivedFor )
  78 import Type             ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
  79                           splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
  80                           getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
  81                         )
  82 import TyVar            ( GenTyVar, GenTyVarSet(..), 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 mod_name == inst_mod
 236         then
 237                 -- Imported instance came from this module;
 238                 -- discard and derive fresh instance
 239             returnTc emptyBag
 240         else
 241                 -- Imported instance declared in another module;
 242                 -- report duplicate instance error
 243             failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
 244     else
 245
 246         -- Make the dfun id and constant-method ids
 247     mkInstanceRelatedIds from_here src_loc inst_mod pragmas
 248                          clas inst_tyvars inst_tau inst_theta uprags
 249                                         `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 250
 251     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
 252                                 dfun_theta dfun_id const_meth_ids
 253                                 binds from_here inst_mod src_loc uprags))
 254 \end{code}
 255
 256
 257 %************************************************************************
 258 %*                                                                      *
 259 \subsection{Type-checking instance declarations, pass 2}
 260 %*                                                                      *
 261 %************************************************************************
 262
 263 \begin{code}
 264 tcInstDecls2 :: Bag InstInfo
 265              -> NF_TcM s (LIE s, TcHsBinds s)
 266
 267 tcInstDecls2 inst_decls
 268   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
 269   where
 270     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 271                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 272                       returnNF_Tc (lie1 `plusLIE` lie2,
 273                                    binds1 `ThenBinds` binds2)
 274 \end{code}
 275
 276
 277 ======= New documentation starts here (Sept 92)  ==============
 278
 279 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 280 the dictionary function for this instance declaration.  For example
 281 \begin{verbatim}
 282         instance Foo a => Foo [a] where
 283                 op1 x = ...
 284                 op2 y = ...
 285 \end{verbatim}
 286 might generate something like
 287 \begin{verbatim}
 288         dfun.Foo.List dFoo_a = let op1 x = ...
 289                                    op2 y = ...
 290                                in
 291                                    Dict [op1, op2]
 292 \end{verbatim}
 293
 294 HOWEVER, if the instance decl has no context, then it returns a
 295 bigger @HsBinds@ with declarations for each method.  For example
 296 \begin{verbatim}
 297         instance Foo [a] where
 298                 op1 x = ...
 299                 op2 y = ...
 300 \end{verbatim}
 301 might produce
 302 \begin{verbatim}
 303         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 304         const.Foo.op1.List a x = ...
 305         const.Foo.op2.List a y = ...
 306 \end{verbatim}
 307 This group may be mutually recursive, because (for example) there may
 308 be no method supplied for op2 in which case we'll get
 309 \begin{verbatim}
 310         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 311 \end{verbatim}
 312 that is, the default method applied to the dictionary at this type.
 313
 314 What we actually produce in either case is:
 315
 316         AbsBinds [a] [dfun_theta_dicts]
 317                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 318                  { d = (sd1,sd2, ..., op1, op2, ...)
 319                    op1 = ...
 320                    op2 = ...
 321                  }
 322
 323 The "maybe" says that we only ask AbsBinds to make global constant methods
 324 if the dfun_theta is empty.
 325
 326
 327 For an instance declaration, say,
 328
 329         instance (C1 a, C2 b) => C (T a b) where
 330                 ...
 331
 332 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 333 function whose type is
 334
 335         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 336
 337 Notice that we pass it the superclass dictionaries at the instance type; this
 338 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 339 is the @dfun_theta@ below.
 340
 341 First comes the easy case of a non-local instance decl.
 342
 343 \begin{code}
 344 tcInstDecl2 :: InstInfo
 345             -> NF_TcM s (LIE s, TcHsBinds s)
 346
 347 tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
 348   = returnNF_Tc (emptyLIE, EmptyBinds)
 349
 350 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 351                       inst_decl_theta dfun_theta
 352                       dfun_id const_meth_ids monobinds
 353                       True{-here-} inst_mod locn uprags)
 354   =      -- Prime error recovery
 355     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds))   $
 356     tcAddSrcLoc locn                                    $
 357
 358         -- Get the class signature
 359     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 360     let
 361         (class_tyvar,
 362          super_classes, sc_sel_ids,
 363          class_ops, op_sel_ids, defm_ids) = classBigSig clas
 364     in
 365     tcInstType tenv inst_ty             `thenNF_Tc` \ inst_ty' ->
 366     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 367     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 368     let
 369         sc_theta'        = super_classes `zip` repeat inst_ty'
 370         origin           = InstanceDeclOrigin
 371         mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
 372     in
 373          -- Create dictionary Ids from the specified instance contexts.
 374     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 375     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 376     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 377     newDicts origin [(clas,inst_ty')]   `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 378
 379          -- Create method variables
 380     mapAndUnzipNF_Tc mk_method op_sel_ids       `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
 381
 382          -- Collect available Insts
 383     let
 384         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 385
 386         avail_insts      -- These insts are in scope; quite a few, eh?
 387           = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
 388
 389         mk_method_expr
 390           = if opt_OmitDefaultInstanceMethods then
 391                 makeInstanceDeclNoDefaultExpr     origin meth_ids defm_ids inst_ty' clas inst_mod
 392             else
 393                 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
 394     in
 395     tcExtendGlobalTyVars inst_tyvars_set' (
 396         processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
 397     )                                   `thenTc` \ (insts_needed, method_mbinds) ->
 398     let
 399         -- Create the dict and method binds
 400         dict_bind
 401             = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 402
 403         dict_and_method_binds
 404             = dict_bind `AndMonoBinds` method_mbinds
 405
 406     in
 407         -- Check the overloading constraints of the methods and superclasses
 408     tcAddErrCtxt (bindSigCtxt meth_ids) (
 409         tcSimplifyAndCheck
 410                  inst_tyvars_set'                       -- Local tyvars
 411                  avail_insts
 412                  (sc_dicts `unionBags` insts_needed)    -- Need to get defns for all these
 413     )                                    `thenTc` \ (const_lie, super_binds) ->
 414
 415         -- Check that we *could* construct the superclass dictionaries,
 416         -- even though we are *actually* going to pass the superclass dicts in;
 417         -- the check ensures that the caller will never have a problem building
 418         -- them.
 419     tcAddErrCtxt superClassSigCtxt (
 420     tcSimplifyAndCheck
 421                  inst_tyvars_set'               -- Local tyvars
 422                  inst_decl_dicts                -- The instance dictionaries available
 423                  sc_dicts                       -- The superclass dicationaries reqd
 424     )                                   `thenTc_`
 425                                                 -- Ignore the result; we're only doing
 426                                                 -- this to make sure it can be done.
 427
 428         -- Now process any SPECIALIZE pragmas for the methods
 429     let
 430         spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
 431     in
 432     tcPragmaSigs spec_sigs              `thenTc` \ (_, spec_binds, spec_lie) ->
 433     let
 434         -- Complete the binding group, adding any spec_binds
 435         inst_binds
 436           = AbsBinds
 437                  inst_tyvars'
 438                  dfun_arg_dicts_ids
 439                  ((this_dict_id, RealId dfun_id)
 440                   : (meth_ids `zip` map RealId const_meth_ids))
 441                         -- NB: const_meth_ids will often be empty
 442                  super_binds
 443                  (RecBind dict_and_method_binds)
 444
 445             `ThenBinds`
 446             spec_binds
 447     in
 448
 449     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 450 \end{code}
 451
 452 The next function makes a default method which calls the global default method, at
 453 the appropriate instance type.
 454
 455 See the notes under default decls in TcClassDcl.lhs.
 456
 457 \begin{code}
 458 makeInstanceDeclDefaultMethodExpr
 459         :: InstOrigin s
 460         -> [TcIdOcc s]
 461         -> [Id]
 462         -> TcType s
 463         -> TcIdOcc s
 464         -> Int
 465         -> NF_TcM s (TcExpr s)
 466
 467 makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
 468   =
 469         -- def_op_id = defm_id inst_ty this_dict
 470     returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
 471  where
 472     idx     = tag - 1
 473     meth_id = meth_ids !! idx
 474     defm_id = defm_ids  !! idx
 475
 476 makeInstanceDeclNoDefaultExpr
 477         :: InstOrigin s
 478         -> [TcIdOcc s]
 479         -> [Id]
 480         -> TcType s
 481         -> Class
 482         -> Module
 483         -> Int
 484         -> NF_TcM s (TcExpr s)
 485
 486 makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
 487   =
 488         -- Produce a warning if the default instance method
 489         -- has been omitted when one exists in the class
 490     warnTc (not err_defm_ok)
 491            (omitDefaultMethodWarn clas_op clas_name inst_ty)
 492                                         `thenNF_Tc_`
 493     returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
 494                        (HsLitOut (HsString (_PK_ error_msg)) stringTy))
 495   where
 496     idx     = tag - 1
 497     meth_id = meth_ids  !! idx
 498     clas_op = (classOps clas) !! idx
 499     defm_id = defm_ids  !! idx
 500
 501     Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 502
 503     error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
 504                 ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
 505                 ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
 506
 507     clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
 508 \end{code}
 509
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsection{Processing each method}
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 @processInstBinds@ returns a @MonoBinds@ which binds
 518 all the method ids (which are passed in).  It is used
 519         - both for instance decls,
 520         - and to compile the default-method declarations in a class decl.
 521
 522 Any method ids which don't have a binding have a suitable default
 523 binding created for them. The actual right-hand side used is
 524 created using a function which is passed in, because the right thing to
 525 do differs between instance and class decls.
 526
 527 \begin{code}
 528 processInstBinds
 529         :: Class
 530         -> (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
 531         -> LIE s                           -- available Insts
 532         -> [TcIdOcc s]                     -- Local method ids in tag order
 533                                            --   (instance tyvars are free in their types)
 534         -> RenamedMonoBinds
 535         -> TcM s (LIE s,                   -- These are required
 536                   TcMonoBinds s)
 537
 538 processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
 539   =
 540          -- Process the explicitly-given method bindings
 541     processInstBinds1 clas avail_insts method_ids monobinds
 542                         `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 543
 544          -- Find the methods not handled, and make default method bindings for them.
 545     let
 546         unmentioned_tags = [1.. length method_ids] `minusList` tags
 547     in
 548     mapNF_Tc mk_default_method unmentioned_tags
 549                         `thenNF_Tc` \ default_bind_list ->
 550
 551     returnTc (insts_needed_in_methods,
 552               foldr AndMonoBinds method_binds default_bind_list)
 553   where
 554         -- From a tag construct us the passed-in function to construct
 555         -- the binding for the default method
 556     mk_default_method tag = mk_default_method_rhs tag   `thenNF_Tc` \ rhs ->
 557                             returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
 558 \end{code}
 559
 560 \begin{code}
 561 processInstBinds1
 562         :: Class
 563         -> LIE s                -- available Insts
 564         -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
 565         -> RenamedMonoBinds
 566         -> TcM s ([Int],        -- Class-op tags accounted for
 567                   LIE s,        -- These are required
 568                   TcMonoBinds s)
 569
 570 processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
 571   = returnTc ([], emptyLIE, EmptyMonoBinds)
 572
 573 processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
 574   = processInstBinds1 clas avail_insts method_ids mb1
 575                                  `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
 576     processInstBinds1 clas avail_insts method_ids mb2
 577                                  `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
 578     returnTc (op_tags1 ++ op_tags2,
 579               dicts1 `unionBags` dicts2,
 580               AndMonoBinds method_binds1 method_binds2)
 581 \end{code}
 582
 583 \begin{code}
 584 processInstBinds1 clas avail_insts method_ids mbind
 585   =
 586     -- Find what class op is being defined here.  The complication is
 587     -- that we could have a PatMonoBind or a FunMonoBind.  If the
 588     -- former, it should only bind a single variable, or else we're in
 589     -- trouble (I'm not sure what the static semantics of methods
 590     -- defined in a pattern binding with multiple patterns is!)
 591     -- Renamer has reduced us to these two cases.
 592     let
 593         (op,locn) = case mbind of
 594                       FunMonoBind op _ _ locn          -> (op, locn)
 595                       PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 596
 597         occ    = getLocalName op
 598         origin = InstanceDeclOrigin
 599     in
 600     tcAddSrcLoc locn                     $
 601
 602     -- Make a method id for the method
 603     let
 604         tag       = classOpTagByString clas occ
 605         method_id = method_ids !! (tag-1)
 606         method_ty = tcIdType method_id
 607     in
 608
 609     tcInstTcType method_ty              `thenNF_Tc` \ (method_tyvars, method_rho) ->
 610     let
 611         (method_theta, method_tau) = splitRhoTy method_rho
 612     in
 613     newDicts origin method_theta        `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 614
 615     case (method_tyvars, method_dict_ids) of
 616
 617       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 618
 619                 -- Type check the method itself
 620         tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 621         returnTc ([tag], lieIop, mbind')
 622
 623       other ->  -- It's a locally-polymorphic and/or overloaded method; UGH!
 624
 625                 -- Make a new id for (a) the local, non-overloaded method
 626                 -- and               (b) the locally-overloaded method
 627                 -- The latter is needed just so we can return an AbsBinds wrapped
 628                 -- up inside a MonoBinds.
 629
 630
 631                 -- Make the method_tyvars into signature tyvars so they
 632                 -- won't get unified with anything.
 633         tcInstSigTyVars method_tyvars           `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
 634         unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys        `thenTc_`
 635
 636         newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
 637         newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
 638         let
 639             sig_tyvar_set = mkTyVarSet sig_tyvars
 640         in
 641                 -- Typecheck the method
 642         tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 643
 644                 -- Check the overloading part of the signature.
 645
 646         -- =========== POSSIBLE BUT NOT DONE =================
 647                 -- Simplify everything fully, even though some
 648                 -- constraints could "really" be left to the next
 649                 -- level out. The case which forces this is
 650                 --
 651                 --      class Foo a where { op :: Bar a => a -> a }
 652                 --
 653                 -- Here we must simplify constraints on "a" to catch all
 654                 -- the Bar-ish things.
 655
 656                 -- We don't do this because it's currently illegal Haskell (not sure why),
 657                 -- and because the local type of the method would have a context at
 658                 -- the front with no for-all, which confuses the hell out of everything!
 659         -- ====================================================
 660
 661         tcAddErrCtxt (methodSigCtxt op method_ty) (
 662             checkSigTyVars
 663                 sig_tyvars method_tau                           `thenTc_`
 664
 665           tcSimplifyAndCheck
 666                 sig_tyvar_set
 667                 (method_dicts `plusLIE` avail_insts)
 668                 lieIop
 669         )                                        `thenTc` \ (f_dicts, dict_binds) ->
 670
 671
 672         returnTc ([tag],
 673                   f_dicts,
 674                   VarMonoBind method_id
 675                          (HsLet
 676                              (AbsBinds
 677                                 method_tyvars
 678                                 method_dict_ids
 679                                 [(local_id, copy_id)]
 680                                 dict_binds
 681                                 (NonRecBind mbind'))
 682                              (HsVar copy_id)))
 683 \end{code}
 684
 685 \begin{code}
 686 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
 687              -> TcM s (TcMonoBinds s, LIE s)
 688
 689 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
 690   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
 691     returnTc (FunMonoBind meth_id inf rhs' locn, lie)
 692
 693 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
 694   -- pat is sure to be a (VarPatIn op)
 695   = tcAddErrCtxt (patMonoBindsCtxt pbind) $
 696     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
 697     unifyTauTy meth_ty rhs_ty           `thenTc_`
 698     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
 699 \end{code}
 700
 701
 702 %************************************************************************
 703 %*                                                                      *
 704 \subsection{Type-checking specialise instance pragmas}
 705 %*                                                                      *
 706 %************************************************************************
 707
 708 \begin{code}
 709 {- LATER
 710 tcSpecInstSigs :: E -> CE -> TCE
 711                -> Bag InstInfo          -- inst decls seen (declared and derived)
 712                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 713                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 714
 715 tcSpecInstSigs e ce tce inst_infos []
 716   = returnTc emptyBag
 717
 718 tcSpecInstSigs e ce tce inst_infos sigs
 719   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 720     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 721     returnTc spec_inst_infos
 722   where
 723     tc_inst_spec_sigs inst_mapper []
 724       = returnNF_Tc emptyBag
 725     tc_inst_spec_sigs inst_mapper (sig:sigs)
 726       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 727         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 728         returnNF_Tc (info_sig `unionBags` info_sigs)
 729
 730 tcSpecInstSig :: E -> CE -> TCE
 731               -> Bag InstInfo
 732               -> InstanceMapper
 733               -> RenamedSpecInstSig
 734               -> NF_TcM (Bag InstInfo)
 735
 736 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 737   = recoverTc emptyBag                  (
 738     tcAddSrcLoc src_loc                 (
 739     let
 740         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 741
 742         -- Make some new type variables, named as in the specialised instance type
 743         ty_names                          = extractMonoTyNames ???is_tyvarish_name??? ty
 744         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 745     in
 746     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 747                                 `thenTc` \ inst_ty ->
 748     let
 749         maybe_tycon = case maybeAppDataTyCon inst_ty of
 750                          Just (tc,_,_) -> Just tc
 751                          Nothing       -> Nothing
 752
 753         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 754     in
 755         -- Check that we have a local instance declaration to specialise
 756     checkMaybeTc maybe_unspec_inst
 757             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 758
 759         -- Create tvs to substitute for tmpls while simplifying the context
 760     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 761     let
 762         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 763                        _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
 764
 765         subst = case matchTy unspec_inst_ty inst_ty of
 766                      Just subst -> subst
 767                      Nothing    -> panic "tcSpecInstSig:matchTy"
 768
 769         subst_theta    = instantiateThetaTy subst unspec_theta
 770         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 771
 772         mk_spec_origin clas ty
 773           = InstanceSpecOrigin inst_mapper clas ty src_loc
 774         -- I'm VERY SUSPICIOUS ABOUT THIS
 775         -- the inst-mapper is in a knot at this point so it's no good
 776         -- looking at it in tcSimplify...
 777     in
 778     tcSimplifyThetas mk_spec_origin subst_tv_theta
 779                                 `thenTc` \ simpl_tv_theta ->
 780     let
 781         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 782
 783         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 784         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 785     in
 786     mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas
 787                          clas inst_tmpls inst_ty simpl_theta uprag
 788                                 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 789
 790     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 791     (if sw_chkr SpecialiseTrace then
 792         pprTrace "Specialised Instance: "
 793         (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
 794                           if null simpl_theta then ppNil else ppStr "=>",
 795                           ppr PprDebug clas,
 796                           pprParendGenType PprDebug inst_ty],
 797                    ppCat [ppStr "        derived from:",
 798                           if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
 799                           if null unspec_theta then ppNil else ppStr "=>",
 800                           ppr PprDebug clas,
 801                           pprParendGenType PprDebug unspec_inst_ty]])
 802     else id) (
 803
 804     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 805                                 dfun_theta dfun_id const_meth_ids
 806                                 binds True{-from here-} mod src_loc uprag))
 807     )))
 808
 809
 810 lookup_unspec_inst clas maybe_tycon inst_infos
 811   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 812         []       -> Nothing
 813         (info:_) -> Just info
 814   where
 815     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 816       = from_here && clas == inst_clas &&
 817         match_ty inst_ty && is_plain_instance inst_ty
 818
 819     match_inst_ty = case maybe_tycon of
 820                       Just tycon -> match_tycon tycon
 821                       Nothing    -> match_fun
 822
 823     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 824           Just (inst_tc,_,_) -> tycon == inst_tc
 825           Nothing            -> False
 826
 827     match_fun inst_ty = isFunType inst_ty
 828
 829
 830 is_plain_instance inst_ty
 831   = case (maybeAppDataTyCon inst_ty) of
 832       Just (_,tys,_) -> all isTyVarTemplateTy tys
 833       Nothing        -> case maybeUnpackFunTy inst_ty of
 834                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 835                           Nothing         -> error "TcInstDecls:is_plain_instance"
 836 -}
 837 \end{code}
 838
 839
 840 Checking for a decent instance type
 841 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 842 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 843 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 844
 845 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 846 flag is on, or (2)~the instance is imported (they must have been
 847 compiled elsewhere). In these cases, we let them go through anyway.
 848
 849 We can also have instances for functions: @instance Foo (a -> b) ...@.
 850
 851 \begin{code}
 852 scrutiniseInstanceType from_here clas inst_tau
 853         -- TYCON CHECK
 854   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 855   = failTc (instTypeErr inst_tau)
 856
 857         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 858   | not from_here
 859   = returnTc (inst_tycon,arg_tys)
 860
 861         -- TYVARS CHECK
 862   | not (all isTyVarTy arg_tys ||
 863          opt_GlasgowExts)
 864   = failTc (instTypeErr inst_tau)
 865
 866         -- DERIVING CHECK
 867         -- It is obviously illegal to have an explicit instance
 868         -- for something that we are also planning to `derive'
 869         -- Though we can have an explicit instance which is more
 870         -- specific than the derived instance
 871   | clas `derivedFor` inst_tycon
 872     && all isTyVarTy arg_tys
 873   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 874
 875   |     -- CCALL CHECK
 876         -- A user declaration of a CCallable/CReturnable instance
 877         -- must be for a "boxed primitive" type.
 878     isCcallishClass clas
 879     && not (maybeToBool (maybeBoxedPrimType inst_tau)
 880             || opt_CompilingGhcInternals) -- this lets us get up to mischief;
 881                                      -- e.g., instance CCallable ()
 882   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 883
 884   | otherwise
 885   = returnTc (inst_tycon,arg_tys)
 886
 887   where
 888     (possible_tycon, arg_tys) = splitAppTy inst_tau
 889     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 890     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 891 \end{code}
 892
 893 \begin{code}
 894
 895 instTypeErr ty sty
 896   = case ty of
 897       SynTy tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg]
 898       TyVarTy tv   -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg]
 899       other        -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg]
 900   where
 901     rest_of_msg = ppStr "' cannot be used as an instance type."
 902
 903 derivingWhenInstanceExistsErr clas tycon sty
 904   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 905          4 (ppStr "when an explicit instance exists")
 906
 907 derivingWhenInstanceImportedErr inst_mod clas tycon sty
 908   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 909          4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
 910   where
 911     pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
 912
 913 nonBoxedPrimCCallErr clas inst_ty sty
 914   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
 915          4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
 916                         ppr sty inst_ty, ppStr "'"])
 917
 918 omitDefaultMethodWarn clas_op clas_name inst_ty sty
 919   = ppCat [ppStr "Warning: Omitted default method for",
 920            ppr sty clas_op, ppStr "in instance",
 921            ppPStr clas_name, pprParendGenType sty inst_ty]
 922
 923
 924 patMonoBindsCtxt pbind sty
 925   = ppHang (ppStr "In a pattern binding:")
 926          4 (ppr sty pbind)
 927
 928 methodSigCtxt name ty sty
 929   = ppHang (ppBesides [ppStr "When matching the definition of class method `",
 930                        ppr sty name, ppStr "' to its signature :" ])
 931          4 (ppr sty ty)
 932
 933 bindSigCtxt method_ids sty
 934   = ppHang (ppStr "When checking type signatures for: ")
 935          4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
 936
 937 superClassSigCtxt sty
 938   = ppStr "When checking superclass constraints on instance declaration"
 939
 940 \end{code}