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     ) where
  13
  14
  15 IMP_Ubiq()
  16
  17 import HsSyn            ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
  18                           FixityDecl, IfaceSig, Sig(..),
  19                           SpecInstSig(..), HsBinds(..),
  20                           MonoBinds(..), GRHSsAndBinds(..), GRHS(..), Match,
  21                           InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  22                           Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity,
  23                           HsType(..), HsTyVar,
  24                           SYN_IE(RecFlag), recursive, nonRecursive, collectMonoBinders,
  25                           andMonoBinds
  26                         )
  27 import RnHsSyn          ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
  28                           SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), SYN_IE(RenamedHsExpr),
  29                           SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
  30                         )
  31 import TcHsSyn          ( SYN_IE(TcHsBinds),
  32                           SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
  33                           mkHsTyLam, mkHsTyApp,
  34                           mkHsDictLam, mkHsDictApp )
  35
  36 import TcBinds          ( tcPragmaSigs )
  37 import TcClassDcl       ( tcMethodBind )
  38 import TcMonad
  39 import RnMonad          ( SYN_IE(RnNameSupply) )
  40 import Inst             ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
  41                           instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
  42 import PragmaInfo       ( PragmaInfo(..) )
  43 import TcDeriv          ( tcDeriving )
  44 import TcEnv            ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars,
  45                           tcExtendGlobalValEnv, tcAddImportedIdInfo
  46                         )
  47 import SpecEnv          ( SpecEnv )
  48 import TcGRHSs          ( tcGRHSsAndBinds )
  49 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  50 import TcKind           ( TcKind, unifyKind )
  51 import TcMatches        ( tcMatchesFun )
  52 import TcMonoType       ( tcTyVarScope, tcContext, tcHsTypeKind )
  53 import TcSimplify       ( tcSimplifyAndCheck )
  54 import TcType           ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
  55                           tcInstSigTyVars, tcInstType, tcInstSigTcType,
  56                           tcInstTheta, tcInstTcType, tcInstSigType
  57                         )
  58 import Unify            ( unifyTauTy, unifyTauTyLists )
  59
  60
  61 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  62                           concatBag, foldBag, bagToList, listToBag,
  63                           Bag )
  64 import CmdLineOpts      ( opt_GlasgowExts, opt_CompilingGhcInternals,
  65                           opt_OmitDefaultInstanceMethods, opt_PprUserLength,
  66                           opt_SpecialiseOverloaded
  67                         )
  68 import Class            ( GenClass,
  69                           classBigSig,
  70                           classDefaultMethodId, SYN_IE(Class)
  71                           )
  72 import Id               ( GenId, idType, replacePragmaInfo,
  73                           isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
  74 import ListSetOps       ( minusList )
  75 import Maybes           ( maybeToBool, expectJust, seqMaybe, catMaybes )
  76 import Name             ( nameOccName, getSrcLoc, mkLocalName,
  77                           isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
  78                           NamedThing(..)
  79                         )
  80 import PrelVals         ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
  81 import PprType          ( GenType, GenTyVar, GenClass, TyCon,
  82                           pprParendGenType
  83                         )
  84 import Outputable
  85 import SrcLoc           ( SrcLoc, noSrcLoc )
  86 import Pretty
  87 import TyCon            ( isSynTyCon, isDataTyCon, derivedClasses )
  88 import Type             ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
  89                           splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
  90                           getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), getTyVar,
  91                           maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
  92                         )
  93 import TyVar            ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
  94                           mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) )
  95 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  96 import TysWiredIn       ( stringTy )
  97 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
  98 import Util             ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..)
  99 #if __GLASGOW_HASKELL__ < 202
 100                           , trace
 101 #endif
 102                         )
 103 \end{code}
 104
 105 Typechecking instance declarations is done in two passes. The first
 106 pass, made by @tcInstDecls1@, collects information to be used in the
 107 second pass.
 108
 109 This pre-processed info includes the as-yet-unprocessed bindings
 110 inside the instance declaration.  These are type-checked in the second
 111 pass, when the class-instance envs and GVE contain all the info from
 112 all the instance and value decls.  Indeed that's the reason we need
 113 two passes over the instance decls.
 114
 115
 116 Here is the overall algorithm.
 117 Assume that we have an instance declaration
 118
 119     instance c => k (t tvs) where b
 120
 121 \begin{enumerate}
 122 \item
 123 $LIE_c$ is the LIE for the context of class $c$
 124 \item
 125 $betas_bar$ is the free variables in the class method type, excluding the
 126    class variable
 127 \item
 128 $LIE_cop$ is the LIE constraining a particular class method
 129 \item
 130 $tau_cop$ is the tau type of a class method
 131 \item
 132 $LIE_i$ is the LIE for the context of instance $i$
 133 \item
 134 $X$ is the instance constructor tycon
 135 \item
 136 $gammas_bar$ is the set of type variables of the instance
 137 \item
 138 $LIE_iop$ is the LIE for a particular class method instance
 139 \item
 140 $tau_iop$ is the tau type for this instance of a class method
 141 \item
 142 $alpha$ is the class variable
 143 \item
 144 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 145 \item
 146 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 147 \end{enumerate}
 148
 149 ToDo: Update the list above with names actually in the code.
 150
 151 \begin{enumerate}
 152 \item
 153 First, make the LIEs for the class and instance contexts, which means
 154 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 155 and make LIElistI and LIEI.
 156 \item
 157 Then process each method in turn.
 158 \item
 159 order the instance methods according to the ordering of the class methods
 160 \item
 161 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 162 \item
 163 Create final dictionary function from bindings generated already
 164 \begin{pseudocode}
 165 df = lambda inst_tyvars
 166        lambda LIEI
 167          let Bop1
 168              Bop2
 169              ...
 170              Bopn
 171          and dbinds_super
 172               in <op1,op2,...,opn,sd1,...,sdm>
 173 \end{pseudocode}
 174 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 175 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 176 \end{enumerate}
 177
 178 \begin{code}
 179 tcInstDecls1 :: TcEnv s                 -- Contains IdInfo for dfun ids
 180              -> [RenamedHsDecl]
 181              -> Module                  -- module name for deriving
 182              -> RnNameSupply                    -- for renaming derivings
 183              -> TcM s (Bag InstInfo,
 184                        RenamedHsBinds,
 185                        PprStyle -> Doc)
 186
 187 tcInstDecls1 unf_env decls mod_name rn_name_supply
 188   =     -- Do the ordinary instance declarations
 189     mapNF_Tc (tcInstDecl1 unf_env mod_name)
 190              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 191     let
 192         decl_inst_info = unionManyBags inst_info_bags
 193     in
 194         -- Handle "derived" instances; note that we only do derivings
 195         -- for things in this module; we ignore deriving decls from
 196         -- interfaces! We pass fixities, because they may be used
 197         -- in deriving Read and Show.
 198     tcDeriving mod_name rn_name_supply decl_inst_info
 199                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 200
 201     let
 202         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 203     in
 204     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 205
 206
 207 tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 208
 209 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 210   =     -- Prime error recovery, set source location
 211     recoverNF_Tc (returnNF_Tc emptyBag) $
 212     tcAddSrcLoc src_loc                 $
 213
 214         -- Look things up
 215     tcLookupClass class_name            `thenTc` \ (clas_kind, clas) ->
 216
 217         -- Typecheck the context and instance type
 218     tcTyVarScope tyvar_names (\ tyvars ->
 219         tcContext context               `thenTc` \ theta ->
 220         tcHsTypeKind inst_ty            `thenTc` \ (tau_kind, tau) ->
 221         unifyKind clas_kind tau_kind    `thenTc_`
 222         returnTc (tyvars, theta, tau)
 223     )                                   `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 224
 225         -- Check for respectable instance type
 226     scrutiniseInstanceType dfun_name clas inst_tau
 227                                         `thenTc` \ (inst_tycon,arg_tys) ->
 228
 229         -- Make the dfun id and constant-method ids
 230     let
 231         (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
 232                                          clas inst_tyvars inst_tau inst_theta
 233         -- Add info from interface file
 234         final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
 235     in
 236     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
 237                         dfun_theta final_dfun_id
 238                                 binds src_loc uprags))
 239   where
 240     (tyvar_names, context, dict_ty) = case poly_ty of
 241                                         HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
 242                                         other                      -> ([],  [],  poly_ty)
 243     (class_name, inst_ty) = case dict_ty of
 244                                 MonoDictTy cls ty -> (cls,ty)
 245                                 other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty)
 246 \end{code}
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection{Type-checking instance declarations, pass 2}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 tcInstDecls2 :: Bag InstInfo
 257              -> NF_TcM s (LIE s, TcMonoBinds s)
 258
 259 tcInstDecls2 inst_decls
 260   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 261   where
 262     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 263                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 264                       returnNF_Tc (lie1 `plusLIE` lie2,
 265                                    binds1 `AndMonoBinds` binds2)
 266 \end{code}
 267
 268
 269 ======= New documentation starts here (Sept 92)  ==============
 270
 271 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 272 the dictionary function for this instance declaration.  For example
 273 \begin{verbatim}
 274         instance Foo a => Foo [a] where
 275                 op1 x = ...
 276                 op2 y = ...
 277 \end{verbatim}
 278 might generate something like
 279 \begin{verbatim}
 280         dfun.Foo.List dFoo_a = let op1 x = ...
 281                                    op2 y = ...
 282                                in
 283                                    Dict [op1, op2]
 284 \end{verbatim}
 285
 286 HOWEVER, if the instance decl has no context, then it returns a
 287 bigger @HsBinds@ with declarations for each method.  For example
 288 \begin{verbatim}
 289         instance Foo [a] where
 290                 op1 x = ...
 291                 op2 y = ...
 292 \end{verbatim}
 293 might produce
 294 \begin{verbatim}
 295         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 296         const.Foo.op1.List a x = ...
 297         const.Foo.op2.List a y = ...
 298 \end{verbatim}
 299 This group may be mutually recursive, because (for example) there may
 300 be no method supplied for op2 in which case we'll get
 301 \begin{verbatim}
 302         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 303 \end{verbatim}
 304 that is, the default method applied to the dictionary at this type.
 305
 306 What we actually produce in either case is:
 307
 308         AbsBinds [a] [dfun_theta_dicts]
 309                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 310                  { d = (sd1,sd2, ..., op1, op2, ...)
 311                    op1 = ...
 312                    op2 = ...
 313                  }
 314
 315 The "maybe" says that we only ask AbsBinds to make global constant methods
 316 if the dfun_theta is empty.
 317
 318
 319 For an instance declaration, say,
 320
 321         instance (C1 a, C2 b) => C (T a b) where
 322                 ...
 323
 324 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 325 function whose type is
 326
 327         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 328
 329 Notice that we pass it the superclass dictionaries at the instance type; this
 330 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 331 is the @dfun_theta@ below.
 332
 333 First comes the easy case of a non-local instance decl.
 334
 335 \begin{code}
 336 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
 337
 338 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 339                       inst_decl_theta dfun_theta
 340                       dfun_id monobinds
 341                       locn uprags)
 342   | not (isLocallyDefined dfun_id)
 343   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 344
 345 {-
 346   -- I deleted this "optimisation" because when importing these
 347   -- instance decls the renamer would look for the dfun bindings and they weren't there.
 348   -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
 349   -- even though it's never used.
 350
 351         -- This case deals with CCallable etc, which don't need any bindings
 352   | isNoDictClass clas
 353   = returnNF_Tc (emptyLIE, EmptyBinds)
 354 -}
 355
 356   | otherwise
 357   =      -- Prime error recovery
 358     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 359     tcAddSrcLoc locn                                       $
 360
 361         -- Get the class signature
 362     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 363     let
 364         origin = InstanceDeclOrigin
 365         (class_tyvar,
 366          super_classes, sc_sel_ids,
 367          op_sel_ids, defm_ids) = classBigSig clas
 368     in
 369     tcInstType tenv inst_ty             `thenNF_Tc` \ inst_ty' ->
 370     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 371     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 372     let
 373         sc_theta'        = super_classes `zip` repeat inst_ty'
 374     in
 375          -- Create dictionary Ids from the specified instance contexts.
 376     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 377     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 378     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 379     newDicts origin [(clas,inst_ty')]   `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 380
 381         -- Now process any INLINE or SPECIALIZE pragmas for the methods
 382         -- ...[NB May 97; all ignored except INLINE]
 383     tcPragmaSigs uprags         `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
 384
 385          -- Check the method bindings
 386     let
 387         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 388         check_from_this_class (bndr, loc)
 389           | nameOccName bndr `elem` sel_names = returnTc ()
 390           | otherwise                         = recoverTc (returnTc ()) $
 391                                                 tcAddSrcLoc loc $
 392                                                 failTc (instBndrErr bndr clas)
 393         sel_names = map getOccName op_sel_ids
 394     in
 395     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))      `thenTc_`
 396     tcExtendGlobalTyVars inst_tyvars_set' (
 397         tcExtendGlobalValEnv (catMaybes defm_ids) $
 398                 -- Default-method Ids may be mentioned in synthesised RHSs
 399         mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds)
 400                        (op_sel_ids `zip` defm_ids)
 401     )                                   `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 402
 403         -- Check the overloading constraints of the methods and superclasses
 404     let
 405         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 406         avail_insts      -- These insts are in scope; quite a few, eh?
 407           = this_dict `plusLIE` dfun_arg_dicts `plusLIE`  unionManyBags meth_lies
 408     in
 409     tcAddErrCtxt bindSigCtxt (
 410         tcSimplifyAndCheck
 411                  inst_tyvars_set'                       -- Local tyvars
 412                  avail_insts
 413                  (sc_dicts `unionBags`
 414                   unionManyBags insts_needed_s)         -- Need to get defns for all these
 415     )                                    `thenTc` \ (const_lie, super_binds) ->
 416
 417         -- Check that we *could* construct the superclass dictionaries,
 418         -- even though we are *actually* going to pass the superclass dicts in;
 419         -- the check ensures that the caller will never have a problem building
 420         -- them.
 421     tcAddErrCtxt superClassSigCtxt (
 422         tcSimplifyAndCheck
 423                  inst_tyvars_set'               -- Local tyvars
 424                  inst_decl_dicts                -- The instance dictionaries available
 425                  sc_dicts                       -- The superclass dicationaries reqd
 426     )                                   `thenTc_`
 427                                                 -- Ignore the result; we're only doing
 428                                                 -- this to make sure it can be done.
 429
 430         -- Create the result bindings
 431     let
 432         dict_bind    = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 433         method_binds = andMonoBinds method_binds_s
 434
 435         main_bind
 436           = AbsBinds
 437                  inst_tyvars'
 438                  dfun_arg_dicts_ids
 439                  [(inst_tyvars', RealId dfun_id, this_dict_id)]
 440                  (super_binds   `AndMonoBinds`
 441                   method_binds  `AndMonoBinds`
 442                   dict_bind)
 443     in
 444     returnTc (const_lie `plusLIE` spec_lie,
 445               main_bind `AndMonoBinds` spec_binds)
 446 \end{code}
 447
 448
 449 %************************************************************************
 450 %*                                                                      *
 451 \subsection{Processing each method}
 452 %*                                                                      *
 453 %************************************************************************
 454
 455 \begin{code}
 456 tcInstMethodBind
 457         :: Class
 458         -> TcType s                                     -- Instance type
 459         -> RenamedMonoBinds                             -- Method binding
 460         -> (Id, Maybe Id)                               -- Selector id and default-method id
 461         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 462
 463 tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
 464   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 465     tcGetUnique                 `thenNF_Tc` \ uniq ->
 466     let
 467         meth_occ          = getOccName sel_id
 468         default_meth_name = mkLocalName uniq meth_occ loc
 469         maybe_meth_bind   = find meth_occ meth_binds
 470         the_meth_bind     = case maybe_meth_bind of
 471                                   Just stuff -> stuff
 472                                   Nothing    -> mk_default_bind default_meth_name
 473     in
 474
 475         -- Warn if no method binding
 476     warnTc (not (maybeToBool maybe_meth_bind) &&
 477             not (maybeToBool maybe_dm_id))
 478            (omittedMethodWarn sel_id clas)              `thenNF_Tc_`
 479
 480         -- Typecheck the method binding
 481     tcMethodBind clas origin inst_ty sel_id the_meth_bind
 482   where
 483     origin = InstanceDeclOrigin         -- Poor
 484
 485     find occ EmptyMonoBinds       = Nothing
 486     find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
 487
 488     find occ b@(FunMonoBind op_name _ _ _)          | nameOccName op_name == occ = Just b
 489                                                     | otherwise           = Nothing
 490     find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
 491                                                     | otherwise           = Nothing
 492     find occ other = panic "Urk! Bad instance method binding"
 493
 494
 495     mk_default_bind local_meth_name
 496       = PatMonoBind (VarPatIn local_meth_name)
 497                     (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
 498                     noSrcLoc
 499
 500     default_expr = case maybe_dm_id of
 501                         Just dm_id -> HsVar (getName dm_id)     -- There's a default method
 502                         Nothing    -> error_expr                -- No default method
 503
 504     error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
 505                               (HsLit (HsString (_PK_ error_msg)))
 506
 507     error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|",
 508                             ppr (PprForUser opt_PprUserLength) sel_id
 509                 ])
 510 \end{code}
 511
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection{Type-checking specialise instance pragmas}
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521 {- LATER
 522 tcSpecInstSigs :: E -> CE -> TCE
 523                -> Bag InstInfo          -- inst decls seen (declared and derived)
 524                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 525                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 526
 527 tcSpecInstSigs e ce tce inst_infos []
 528   = returnTc emptyBag
 529
 530 tcSpecInstSigs e ce tce inst_infos sigs
 531   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 532     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 533     returnTc spec_inst_infos
 534   where
 535     tc_inst_spec_sigs inst_mapper []
 536       = returnNF_Tc emptyBag
 537     tc_inst_spec_sigs inst_mapper (sig:sigs)
 538       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 539         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 540         returnNF_Tc (info_sig `unionBags` info_sigs)
 541
 542 tcSpecInstSig :: E -> CE -> TCE
 543               -> Bag InstInfo
 544               -> InstanceMapper
 545               -> RenamedSpecInstSig
 546               -> NF_TcM (Bag InstInfo)
 547
 548 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 549   = recoverTc emptyBag                  (
 550     tcAddSrcLoc src_loc                 (
 551     let
 552         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 553
 554         -- Make some new type variables, named as in the specialised instance type
 555         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 556         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 557     in
 558     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 559                                 `thenTc` \ inst_ty ->
 560     let
 561         maybe_tycon = case maybeAppDataTyCon inst_ty of
 562                          Just (tc,_,_) -> Just tc
 563                          Nothing       -> Nothing
 564
 565         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 566     in
 567         -- Check that we have a local instance declaration to specialise
 568     checkMaybeTc maybe_unspec_inst
 569             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 570
 571         -- Create tvs to substitute for tmpls while simplifying the context
 572     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 573     let
 574         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 575                        _ _ binds _ uprag) = maybe_unspec_inst
 576
 577         subst = case matchTy unspec_inst_ty inst_ty of
 578                      Just subst -> subst
 579                      Nothing    -> panic "tcSpecInstSig:matchTy"
 580
 581         subst_theta    = instantiateThetaTy subst unspec_theta
 582         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 583
 584         mk_spec_origin clas ty
 585           = InstanceSpecOrigin inst_mapper clas ty src_loc
 586         -- I'm VERY SUSPICIOUS ABOUT THIS
 587         -- the inst-mapper is in a knot at this point so it's no good
 588         -- looking at it in tcSimplify...
 589     in
 590     tcSimplifyThetas mk_spec_origin subst_tv_theta
 591                                 `thenTc` \ simpl_tv_theta ->
 592     let
 593         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 594
 595         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 596         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 597     in
 598     mkInstanceRelatedIds
 599                          clas inst_tmpls inst_ty simpl_theta uprag
 600                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 601
 602     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 603     (if sw_chkr SpecialiseTrace then
 604         pprTrace "Specialised Instance: "
 605         (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta,
 606                           if null simpl_theta then empty else ptext SLIT("=>"),
 607                           ppr PprDebug clas,
 608                           pprParendGenType PprDebug inst_ty],
 609                    hsep [ptext SLIT("        derived from:"),
 610                           if null unspec_theta then empty else ppr PprDebug unspec_theta,
 611                           if null unspec_theta then empty else ptext SLIT("=>"),
 612                           ppr PprDebug clas,
 613                           pprParendGenType PprDebug unspec_inst_ty]])
 614     else id) (
 615
 616     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 617                                 dfun_theta dfun_id
 618                                 binds src_loc uprag))
 619     )))
 620
 621
 622 lookup_unspec_inst clas maybe_tycon inst_infos
 623   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 624         []       -> Nothing
 625         (info:_) -> Just info
 626   where
 627     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 628       = from_here && clas == inst_clas &&
 629         match_ty inst_ty && is_plain_instance inst_ty
 630
 631     match_inst_ty = case maybe_tycon of
 632                       Just tycon -> match_tycon tycon
 633                       Nothing    -> match_fun
 634
 635     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 636           Just (inst_tc,_,_) -> tycon == inst_tc
 637           Nothing            -> False
 638
 639     match_fun inst_ty = isFunType inst_ty
 640
 641
 642 is_plain_instance inst_ty
 643   = case (maybeAppDataTyCon inst_ty) of
 644       Just (_,tys,_) -> all isTyVarTemplateTy tys
 645       Nothing        -> case maybeUnpackFunTy inst_ty of
 646                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 647                           Nothing         -> error "TcInstDecls:is_plain_instance"
 648 -}
 649 \end{code}
 650
 651
 652 Checking for a decent instance type
 653 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 654 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 655 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 656
 657 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 658 flag is on, or (2)~the instance is imported (they must have been
 659 compiled elsewhere). In these cases, we let them go through anyway.
 660
 661 We can also have instances for functions: @instance Foo (a -> b) ...@.
 662
 663 \begin{code}
 664 scrutiniseInstanceType dfun_name clas inst_tau
 665         -- TYCON CHECK
 666   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 667   = failTc (instTypeErr inst_tau)
 668
 669         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 670   | not (isLocallyDefined dfun_name)
 671   = returnTc (inst_tycon,arg_tys)
 672
 673         -- TYVARS CHECK
 674   | not (opt_GlasgowExts ||
 675          (all isTyVarTy arg_tys && null tyvar_dups)
 676     )
 677   = failTc (instTypeErr inst_tau)
 678
 679         -- DERIVING CHECK
 680         -- It is obviously illegal to have an explicit instance
 681         -- for something that we are also planning to `derive'
 682         -- Though we can have an explicit instance which is more
 683         -- specific than the derived instance
 684   | clas `elem` (derivedClasses inst_tycon)
 685     && all isTyVarTy arg_tys
 686   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 687
 688   |     -- CCALL CHECK
 689         -- A user declaration of a CCallable/CReturnable instance
 690         -- must be for a "boxed primitive" type.
 691     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 692     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 693   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 694
 695   | otherwise
 696   = returnTc (inst_tycon,arg_tys)
 697
 698   where
 699     (possible_tycon, arg_tys) = splitAppTys inst_tau
 700     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 701     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 702     (_, tyvar_dups)           = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
 703
 704 -- These conditions come directly from what the DsCCall is capable of.
 705 -- Totally grotesque.  Green card should solve this.
 706
 707 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 708                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 709                       ty `eqTy` stringTy ||
 710                       byte_arr_thing
 711   where
 712     byte_arr_thing = case maybeAppDataTyCon ty of
 713                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 714                                 length data_con_arg_tys == 2 &&
 715                                 maybeToBool maybe_arg2_tycon &&
 716                                 (arg2_tycon == byteArrayPrimTyCon ||
 717                                  arg2_tycon == mutableByteArrayPrimTyCon)
 718                              where
 719                                 data_con_arg_tys = dataConArgTys data_con ty_args
 720                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 721                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 722                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 723
 724                         other -> False
 725
 726 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 727                         -- Or, a data type with a single nullary constructor
 728                       case (maybeAppDataTyCon ty) of
 729                         Just (tycon, tys_applied, [data_con])
 730                                 -> isNullaryDataCon data_con
 731                         other -> False
 732 \end{code}
 733
 734 \begin{code}
 735
 736 instTypeErr ty sty
 737   = case ty of
 738       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
 739       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
 740       other        -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
 741   where
 742     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 743
 744 instBndrErr bndr clas sty
 745   = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
 746
 747 derivingWhenInstanceExistsErr clas tycon sty
 748   = hang (hsep [ptext SLIT("Deriving class"),
 749                        ppr sty clas,
 750                        ptext SLIT("type"), ppr sty tycon])
 751          4 (ptext SLIT("when an explicit instance exists"))
 752
 753 nonBoxedPrimCCallErr clas inst_ty sty
 754   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 755          4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
 756                         ppr sty inst_ty])
 757
 758 omittedMethodWarn sel_id clas sty
 759   = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id,
 760          ptext SLIT("in an instance declaration for") <+> ppr sty clas]
 761
 762 instMethodNotInClassErr occ clas sty
 763   = hang (ptext SLIT("Instance mentions a method not in the class"))
 764          4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
 765                        ppr sty occ])
 766
 767 patMonoBindsCtxt pbind sty
 768   = hang (ptext SLIT("In a pattern binding:"))
 769          4 (ppr sty pbind)
 770
 771 methodSigCtxt name ty sty
 772   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 773                        ppr sty name, ptext SLIT("to its signature :") ])
 774          4 (ppr sty ty)
 775
 776 bindSigCtxt sty
 777   = ptext SLIT("When checking methods of an instance declaration")
 778
 779 superClassSigCtxt sty
 780   = ptext SLIT("When checking superclass constraints of an instance declaration")
 781 \end{code}