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,
  65                           opt_PprUserLength, opt_SpecialiseOverloaded,
  66                           opt_WarnMissingMethods
  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!
 197     tcDeriving mod_name rn_name_supply decl_inst_info
 198                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 199
 200     let
 201         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 202     in
 203     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 204
 205
 206 tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 207
 208 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 209   =     -- Prime error recovery, set source location
 210     recoverNF_Tc (returnNF_Tc emptyBag) $
 211     tcAddSrcLoc src_loc                 $
 212
 213         -- Look things up
 214     tcLookupClass class_name            `thenTc` \ (clas_kind, clas) ->
 215
 216         -- Typecheck the context and instance type
 217     tcTyVarScope tyvar_names (\ tyvars ->
 218         tcContext context               `thenTc` \ theta ->
 219         tcHsTypeKind inst_ty            `thenTc` \ (tau_kind, tau) ->
 220         unifyKind clas_kind tau_kind    `thenTc_`
 221         returnTc (tyvars, theta, tau)
 222     )                                   `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 223
 224         -- Check for respectable instance type
 225     scrutiniseInstanceType dfun_name clas inst_tau
 226                                         `thenTc` \ (inst_tycon,arg_tys) ->
 227
 228         -- Make the dfun id and constant-method ids
 229     let
 230         (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
 231                                          clas inst_tyvars inst_tau inst_theta
 232         -- Add info from interface file
 233         final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
 234     in
 235     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
 236                         dfun_theta final_dfun_id
 237                                 binds src_loc uprags))
 238   where
 239     (tyvar_names, context, dict_ty) = case poly_ty of
 240                                         HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
 241                                         other                      -> ([],  [],  poly_ty)
 242     (class_name, inst_ty) = case dict_ty of
 243                                 MonoDictTy cls ty -> (cls,ty)
 244                                 other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty)
 245 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection{Type-checking instance declarations, pass 2}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 \begin{code}
 255 tcInstDecls2 :: Bag InstInfo
 256              -> NF_TcM s (LIE s, TcMonoBinds s)
 257
 258 tcInstDecls2 inst_decls
 259   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 260   where
 261     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 262                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 263                       returnNF_Tc (lie1 `plusLIE` lie2,
 264                                    binds1 `AndMonoBinds` binds2)
 265 \end{code}
 266
 267
 268 ======= New documentation starts here (Sept 92)  ==============
 269
 270 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 271 the dictionary function for this instance declaration.  For example
 272 \begin{verbatim}
 273         instance Foo a => Foo [a] where
 274                 op1 x = ...
 275                 op2 y = ...
 276 \end{verbatim}
 277 might generate something like
 278 \begin{verbatim}
 279         dfun.Foo.List dFoo_a = let op1 x = ...
 280                                    op2 y = ...
 281                                in
 282                                    Dict [op1, op2]
 283 \end{verbatim}
 284
 285 HOWEVER, if the instance decl has no context, then it returns a
 286 bigger @HsBinds@ with declarations for each method.  For example
 287 \begin{verbatim}
 288         instance Foo [a] where
 289                 op1 x = ...
 290                 op2 y = ...
 291 \end{verbatim}
 292 might produce
 293 \begin{verbatim}
 294         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 295         const.Foo.op1.List a x = ...
 296         const.Foo.op2.List a y = ...
 297 \end{verbatim}
 298 This group may be mutually recursive, because (for example) there may
 299 be no method supplied for op2 in which case we'll get
 300 \begin{verbatim}
 301         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 302 \end{verbatim}
 303 that is, the default method applied to the dictionary at this type.
 304
 305 What we actually produce in either case is:
 306
 307         AbsBinds [a] [dfun_theta_dicts]
 308                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 309                  { d = (sd1,sd2, ..., op1, op2, ...)
 310                    op1 = ...
 311                    op2 = ...
 312                  }
 313
 314 The "maybe" says that we only ask AbsBinds to make global constant methods
 315 if the dfun_theta is empty.
 316
 317
 318 For an instance declaration, say,
 319
 320         instance (C1 a, C2 b) => C (T a b) where
 321                 ...
 322
 323 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 324 function whose type is
 325
 326         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 327
 328 Notice that we pass it the superclass dictionaries at the instance type; this
 329 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 330 is the @dfun_theta@ below.
 331
 332 First comes the easy case of a non-local instance decl.
 333
 334 \begin{code}
 335 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
 336
 337 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 338                       inst_decl_theta dfun_theta
 339                       dfun_id monobinds
 340                       locn uprags)
 341   | not (isLocallyDefined dfun_id)
 342   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 343
 344 {-
 345   -- I deleted this "optimisation" because when importing these
 346   -- instance decls the renamer would look for the dfun bindings and they weren't there.
 347   -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
 348   -- even though it's never used.
 349
 350         -- This case deals with CCallable etc, which don't need any bindings
 351   | isNoDictClass clas
 352   = returnNF_Tc (emptyLIE, EmptyBinds)
 353 -}
 354
 355   | otherwise
 356   =      -- Prime error recovery
 357     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 358     tcAddSrcLoc locn                                       $
 359
 360         -- Get the class signature
 361     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 362     let
 363         origin = InstanceDeclOrigin
 364         (class_tyvar,
 365          super_classes, sc_sel_ids,
 366          op_sel_ids, defm_ids) = classBigSig clas
 367     in
 368     tcInstType tenv inst_ty             `thenNF_Tc` \ inst_ty' ->
 369     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 370     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 371     let
 372         sc_theta'        = super_classes `zip` repeat inst_ty'
 373     in
 374          -- Create dictionary Ids from the specified instance contexts.
 375     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 376     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 377     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 378     newDicts origin [(clas,inst_ty')]   `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 379
 380         -- Now process any INLINE or SPECIALIZE pragmas for the methods
 381         -- ...[NB May 97; all ignored except INLINE]
 382     tcPragmaSigs uprags         `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
 383
 384          -- Check the method bindings
 385     let
 386         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 387         check_from_this_class (bndr, loc)
 388           | nameOccName bndr `elem` sel_names = returnTc ()
 389           | otherwise                         = recoverTc (returnTc ()) $
 390                                                 tcAddSrcLoc loc $
 391                                                 failTc (instBndrErr bndr clas)
 392         sel_names = map getOccName op_sel_ids
 393     in
 394     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))      `thenTc_`
 395     tcExtendGlobalTyVars inst_tyvars_set' (
 396         tcExtendGlobalValEnv (catMaybes defm_ids) $
 397                 -- Default-method Ids may be mentioned in synthesised RHSs
 398         mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds)
 399                        (op_sel_ids `zip` defm_ids)
 400     )                                   `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 401
 402         -- Check the overloading constraints of the methods and superclasses
 403     let
 404         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 405         avail_insts      -- These insts are in scope; quite a few, eh?
 406           = this_dict `plusLIE` dfun_arg_dicts `plusLIE`  unionManyBags meth_lies
 407     in
 408     tcAddErrCtxt bindSigCtxt (
 409         tcSimplifyAndCheck
 410                  inst_tyvars_set'                       -- Local tyvars
 411                  avail_insts
 412                  (sc_dicts `unionBags`
 413                   unionManyBags insts_needed_s)         -- Need to get defns for all these
 414     )                                    `thenTc` \ (const_lie, super_binds) ->
 415
 416         -- Check that we *could* construct the superclass dictionaries,
 417         -- even though we are *actually* going to pass the superclass dicts in;
 418         -- the check ensures that the caller will never have a problem building
 419         -- them.
 420     tcAddErrCtxt superClassSigCtxt (
 421         tcSimplifyAndCheck
 422                  inst_tyvars_set'               -- Local tyvars
 423                  inst_decl_dicts                -- The instance dictionaries available
 424                  sc_dicts                       -- The superclass dicationaries reqd
 425     )                                   `thenTc_`
 426                                                 -- Ignore the result; we're only doing
 427                                                 -- this to make sure it can be done.
 428
 429         -- Create the result bindings
 430     let
 431         dict_bind    = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 432         method_binds = andMonoBinds method_binds_s
 433
 434         main_bind
 435           = AbsBinds
 436                  inst_tyvars'
 437                  dfun_arg_dicts_ids
 438                  [(inst_tyvars', RealId dfun_id, this_dict_id)]
 439                  (super_binds   `AndMonoBinds`
 440                   method_binds  `AndMonoBinds`
 441                   dict_bind)
 442     in
 443     returnTc (const_lie `plusLIE` spec_lie,
 444               main_bind `AndMonoBinds` spec_binds)
 445 \end{code}
 446
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsection{Processing each method}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 \begin{code}
 455 tcInstMethodBind
 456         :: Class
 457         -> TcType s                                     -- Instance type
 458         -> RenamedMonoBinds                             -- Method binding
 459         -> (Id, Maybe Id)                               -- Selector id and default-method id
 460         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 461
 462 tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
 463   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 464     tcGetUnique                 `thenNF_Tc` \ uniq ->
 465     let
 466         meth_occ          = getOccName sel_id
 467         default_meth_name = mkLocalName uniq meth_occ loc
 468         maybe_meth_bind   = find meth_occ meth_binds
 469         the_meth_bind     = case maybe_meth_bind of
 470                                   Just stuff -> stuff
 471                                   Nothing    -> mk_default_bind default_meth_name
 472     in
 473
 474         -- Warn if no method binding, only if -fwarn-missing-methods
 475
 476     warnTc (opt_WarnMissingMethods &&
 477             not (maybeToBool maybe_meth_bind) &&
 478             not (maybeToBool maybe_dm_id))
 479         (omittedMethodWarn sel_id clas)         `thenNF_Tc_`
 480
 481         -- Typecheck the method binding
 482     tcMethodBind clas origin inst_ty sel_id the_meth_bind
 483   where
 484     origin = InstanceDeclOrigin         -- Poor
 485
 486     find occ EmptyMonoBinds       = Nothing
 487     find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
 488
 489     find occ b@(FunMonoBind op_name _ _ _)          | nameOccName op_name == occ = Just b
 490                                                     | otherwise           = Nothing
 491     find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
 492                                                     | otherwise           = Nothing
 493     find occ other = panic "Urk! Bad instance method binding"
 494
 495
 496     mk_default_bind local_meth_name
 497       = PatMonoBind (VarPatIn local_meth_name)
 498                     (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
 499                     noSrcLoc
 500
 501     default_expr = case maybe_dm_id of
 502                         Just dm_id -> HsVar (getName dm_id)     -- There's a default method
 503                         Nothing    -> error_expr                -- No default method
 504
 505     error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
 506                               (HsLit (HsString (_PK_ error_msg)))
 507
 508     error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|",
 509                             ppr (PprForUser opt_PprUserLength) sel_id
 510                 ])
 511 \end{code}
 512
 513
 514
 515 %************************************************************************
 516 %*                                                                      *
 517 \subsection{Type-checking specialise instance pragmas}
 518 %*                                                                      *
 519 %************************************************************************
 520
 521 \begin{code}
 522 {- LATER
 523 tcSpecInstSigs :: E -> CE -> TCE
 524                -> Bag InstInfo          -- inst decls seen (declared and derived)
 525                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 526                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 527
 528 tcSpecInstSigs e ce tce inst_infos []
 529   = returnTc emptyBag
 530
 531 tcSpecInstSigs e ce tce inst_infos sigs
 532   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 533     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 534     returnTc spec_inst_infos
 535   where
 536     tc_inst_spec_sigs inst_mapper []
 537       = returnNF_Tc emptyBag
 538     tc_inst_spec_sigs inst_mapper (sig:sigs)
 539       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 540         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 541         returnNF_Tc (info_sig `unionBags` info_sigs)
 542
 543 tcSpecInstSig :: E -> CE -> TCE
 544               -> Bag InstInfo
 545               -> InstanceMapper
 546               -> RenamedSpecInstSig
 547               -> NF_TcM (Bag InstInfo)
 548
 549 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 550   = recoverTc emptyBag                  (
 551     tcAddSrcLoc src_loc                 (
 552     let
 553         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 554
 555         -- Make some new type variables, named as in the specialised instance type
 556         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 557         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 558     in
 559     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 560                                 `thenTc` \ inst_ty ->
 561     let
 562         maybe_tycon = case maybeAppDataTyCon inst_ty of
 563                          Just (tc,_,_) -> Just tc
 564                          Nothing       -> Nothing
 565
 566         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 567     in
 568         -- Check that we have a local instance declaration to specialise
 569     checkMaybeTc maybe_unspec_inst
 570             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 571
 572         -- Create tvs to substitute for tmpls while simplifying the context
 573     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 574     let
 575         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 576                        _ _ binds _ uprag) = maybe_unspec_inst
 577
 578         subst = case matchTy unspec_inst_ty inst_ty of
 579                      Just subst -> subst
 580                      Nothing    -> panic "tcSpecInstSig:matchTy"
 581
 582         subst_theta    = instantiateThetaTy subst unspec_theta
 583         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 584
 585         mk_spec_origin clas ty
 586           = InstanceSpecOrigin inst_mapper clas ty src_loc
 587         -- I'm VERY SUSPICIOUS ABOUT THIS
 588         -- the inst-mapper is in a knot at this point so it's no good
 589         -- looking at it in tcSimplify...
 590     in
 591     tcSimplifyThetas mk_spec_origin subst_tv_theta
 592                                 `thenTc` \ simpl_tv_theta ->
 593     let
 594         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 595
 596         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 597         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 598     in
 599     mkInstanceRelatedIds
 600                          clas inst_tmpls inst_ty simpl_theta uprag
 601                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 602
 603     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 604     (if sw_chkr SpecialiseTrace then
 605         pprTrace "Specialised Instance: "
 606         (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta,
 607                           if null simpl_theta then empty else ptext SLIT("=>"),
 608                           ppr PprDebug clas,
 609                           pprParendGenType PprDebug inst_ty],
 610                    hsep [ptext SLIT("        derived from:"),
 611                           if null unspec_theta then empty else ppr PprDebug unspec_theta,
 612                           if null unspec_theta then empty else ptext SLIT("=>"),
 613                           ppr PprDebug clas,
 614                           pprParendGenType PprDebug unspec_inst_ty]])
 615     else id) (
 616
 617     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 618                                 dfun_theta dfun_id
 619                                 binds src_loc uprag))
 620     )))
 621
 622
 623 lookup_unspec_inst clas maybe_tycon inst_infos
 624   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 625         []       -> Nothing
 626         (info:_) -> Just info
 627   where
 628     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 629       = from_here && clas == inst_clas &&
 630         match_ty inst_ty && is_plain_instance inst_ty
 631
 632     match_inst_ty = case maybe_tycon of
 633                       Just tycon -> match_tycon tycon
 634                       Nothing    -> match_fun
 635
 636     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 637           Just (inst_tc,_,_) -> tycon == inst_tc
 638           Nothing            -> False
 639
 640     match_fun inst_ty = isFunType inst_ty
 641
 642
 643 is_plain_instance inst_ty
 644   = case (maybeAppDataTyCon inst_ty) of
 645       Just (_,tys,_) -> all isTyVarTemplateTy tys
 646       Nothing        -> case maybeUnpackFunTy inst_ty of
 647                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 648                           Nothing         -> error "TcInstDecls:is_plain_instance"
 649 -}
 650 \end{code}
 651
 652
 653 Checking for a decent instance type
 654 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 655 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 656 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 657
 658 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 659 flag is on, or (2)~the instance is imported (they must have been
 660 compiled elsewhere). In these cases, we let them go through anyway.
 661
 662 We can also have instances for functions: @instance Foo (a -> b) ...@.
 663
 664 \begin{code}
 665 scrutiniseInstanceType dfun_name clas inst_tau
 666         -- TYCON CHECK
 667   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 668   = failTc (instTypeErr inst_tau)
 669
 670         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 671   | not (isLocallyDefined dfun_name)
 672   = returnTc (inst_tycon,arg_tys)
 673
 674         -- TYVARS CHECK
 675   | not (opt_GlasgowExts ||
 676          (all isTyVarTy arg_tys && null tyvar_dups)
 677     )
 678   = failTc (instTypeErr inst_tau)
 679
 680         -- DERIVING CHECK
 681         -- It is obviously illegal to have an explicit instance
 682         -- for something that we are also planning to `derive'
 683         -- Though we can have an explicit instance which is more
 684         -- specific than the derived instance
 685   | clas `elem` (derivedClasses inst_tycon)
 686     && all isTyVarTy arg_tys
 687   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 688
 689   |     -- CCALL CHECK
 690         -- A user declaration of a CCallable/CReturnable instance
 691         -- must be for a "boxed primitive" type.
 692     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 693     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 694   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 695
 696   | otherwise
 697   = returnTc (inst_tycon,arg_tys)
 698
 699   where
 700     (possible_tycon, arg_tys) = splitAppTys inst_tau
 701     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 702     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 703     (_, tyvar_dups)           = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
 704
 705 -- These conditions come directly from what the DsCCall is capable of.
 706 -- Totally grotesque.  Green card should solve this.
 707
 708 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 709                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 710                       ty `eqTy` stringTy ||
 711                       byte_arr_thing
 712   where
 713     byte_arr_thing = case maybeAppDataTyCon ty of
 714                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 715                                 length data_con_arg_tys == 2 &&
 716                                 maybeToBool maybe_arg2_tycon &&
 717                                 (arg2_tycon == byteArrayPrimTyCon ||
 718                                  arg2_tycon == mutableByteArrayPrimTyCon)
 719                              where
 720                                 data_con_arg_tys = dataConArgTys data_con ty_args
 721                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 722                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 723                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 724
 725                         other -> False
 726
 727 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 728                         -- Or, a data type with a single nullary constructor
 729                       case (maybeAppDataTyCon ty) of
 730                         Just (tycon, tys_applied, [data_con])
 731                                 -> isNullaryDataCon data_con
 732                         other -> False
 733 \end{code}
 734
 735 \begin{code}
 736
 737 instTypeErr ty sty
 738   = case ty of
 739       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
 740       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
 741       other        -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
 742   where
 743     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 744
 745 instBndrErr bndr clas sty
 746   = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
 747
 748 derivingWhenInstanceExistsErr clas tycon sty
 749   = hang (hsep [ptext SLIT("Deriving class"),
 750                        ppr sty clas,
 751                        ptext SLIT("type"), ppr sty tycon])
 752          4 (ptext SLIT("when an explicit instance exists"))
 753
 754 nonBoxedPrimCCallErr clas inst_ty sty
 755   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 756          4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
 757                         ppr sty inst_ty])
 758
 759 omittedMethodWarn sel_id clas sty
 760   = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> ppr sty sel_id,
 761          ptext SLIT("in an instance declaration for") <+> ppr sty clas]
 762
 763 instMethodNotInClassErr occ clas sty
 764   = hang (ptext SLIT("Instance mentions a method not in the class"))
 765          4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
 766                        ppr sty occ])
 767
 768 patMonoBindsCtxt pbind sty
 769   = hang (ptext SLIT("In a pattern binding:"))
 770          4 (ppr sty pbind)
 771
 772 methodSigCtxt name ty sty
 773   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 774                        ppr sty name, ptext SLIT("to its signature :") ])
 775          4 (ppr sty ty)
 776
 777 bindSigCtxt sty
 778   = ptext SLIT("When checking methods of an instance declaration")
 779
 780 superClassSigCtxt sty
 781   = ptext SLIT("When checking superclass constraints of an instance declaration")
 782 \end{code}