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