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_OmitDefaultInstanceMethods,
  65                           opt_PprUserLength, opt_SpecialiseOverloaded
  66                         )
  67 import Class            ( GenClass,
  68                           classBigSig,
  69                           classDefaultMethodId, SYN_IE(Class)
  70                           )
  71 import Id               ( GenId, idType, replacePragmaInfo,
  72                           isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
  73 import ListSetOps       ( minusList )
  74 import Maybes           ( maybeToBool, expectJust, seqMaybe, catMaybes )
  75 import Name             ( nameOccName, getSrcLoc, mkLocalName,
  76                           isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
  77                           NamedThing(..)
  78                         )
  79 import PrelVals         ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
  80 import PprType          ( GenType, GenTyVar, GenClass, TyCon,
  81                           pprParendGenType
  82                         )
  83 import Outputable
  84 import SrcLoc           ( SrcLoc, noSrcLoc )
  85 import Pretty
  86 import TyCon            ( isSynTyCon, isDataTyCon, derivedClasses )
  87 import Type             ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
  88                           splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
  89                           getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), getTyVar,
  90                           maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
  91                         )
  92 import TyVar            ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
  93                           mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) )
  94 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  95 import TysWiredIn       ( stringTy )
  96 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
  97 import Util             ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..)
  98 #if __GLASGOW_HASKELL__ < 202
  99                           , trace
 100 #endif
 101                         )
 102 \end{code}
 103
 104 Typechecking instance declarations is done in two passes. The first
 105 pass, made by @tcInstDecls1@, collects information to be used in the
 106 second pass.
 107
 108 This pre-processed info includes the as-yet-unprocessed bindings
 109 inside the instance declaration.  These are type-checked in the second
 110 pass, when the class-instance envs and GVE contain all the info from
 111 all the instance and value decls.  Indeed that's the reason we need
 112 two passes over the instance decls.
 113
 114
 115 Here is the overall algorithm.
 116 Assume that we have an instance declaration
 117
 118     instance c => k (t tvs) where b
 119
 120 \begin{enumerate}
 121 \item
 122 $LIE_c$ is the LIE for the context of class $c$
 123 \item
 124 $betas_bar$ is the free variables in the class method type, excluding the
 125    class variable
 126 \item
 127 $LIE_cop$ is the LIE constraining a particular class method
 128 \item
 129 $tau_cop$ is the tau type of a class method
 130 \item
 131 $LIE_i$ is the LIE for the context of instance $i$
 132 \item
 133 $X$ is the instance constructor tycon
 134 \item
 135 $gammas_bar$ is the set of type variables of the instance
 136 \item
 137 $LIE_iop$ is the LIE for a particular class method instance
 138 \item
 139 $tau_iop$ is the tau type for this instance of a class method
 140 \item
 141 $alpha$ is the class variable
 142 \item
 143 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 144 \item
 145 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 146 \end{enumerate}
 147
 148 ToDo: Update the list above with names actually in the code.
 149
 150 \begin{enumerate}
 151 \item
 152 First, make the LIEs for the class and instance contexts, which means
 153 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 154 and make LIElistI and LIEI.
 155 \item
 156 Then process each method in turn.
 157 \item
 158 order the instance methods according to the ordering of the class methods
 159 \item
 160 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 161 \item
 162 Create final dictionary function from bindings generated already
 163 \begin{pseudocode}
 164 df = lambda inst_tyvars
 165        lambda LIEI
 166          let Bop1
 167              Bop2
 168              ...
 169              Bopn
 170          and dbinds_super
 171               in <op1,op2,...,opn,sd1,...,sdm>
 172 \end{pseudocode}
 173 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 174 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 175 \end{enumerate}
 176
 177 \begin{code}
 178 tcInstDecls1 :: TcEnv s                 -- Contains IdInfo for dfun ids
 179              -> [RenamedHsDecl]
 180              -> Module                  -- module name for deriving
 181              -> RnNameSupply                    -- for renaming derivings
 182              -> TcM s (Bag InstInfo,
 183                        RenamedHsBinds,
 184                        PprStyle -> Doc)
 185
 186 tcInstDecls1 unf_env decls mod_name rn_name_supply
 187   =     -- Do the ordinary instance declarations
 188     mapNF_Tc (tcInstDecl1 unf_env mod_name)
 189              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 190     let
 191         decl_inst_info = unionManyBags inst_info_bags
 192     in
 193         -- Handle "derived" instances; note that we only do derivings
 194         -- for things in this module; we ignore deriving decls from
 195         -- interfaces! We pass fixities, because they may be used
 196         -- in deriving Read and Show.
 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
 475     warnTc (not (maybeToBool maybe_meth_bind) &&
 476             not (maybeToBool maybe_dm_id))
 477            (omittedMethodWarn sel_id clas)              `thenNF_Tc_`
 478
 479         -- Typecheck the method binding
 480     tcMethodBind clas origin inst_ty sel_id the_meth_bind
 481   where
 482     origin = InstanceDeclOrigin         -- Poor
 483
 484     find occ EmptyMonoBinds       = Nothing
 485     find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
 486
 487     find occ b@(FunMonoBind op_name _ _ _)          | nameOccName op_name == occ = Just b
 488                                                     | otherwise           = Nothing
 489     find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
 490                                                     | otherwise           = Nothing
 491     find occ other = panic "Urk! Bad instance method binding"
 492
 493
 494     mk_default_bind local_meth_name
 495       = PatMonoBind (VarPatIn local_meth_name)
 496                     (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
 497                     noSrcLoc
 498
 499     default_expr = case maybe_dm_id of
 500                         Just dm_id -> HsVar (getName dm_id)     -- There's a default method
 501                         Nothing    -> error_expr                -- No default method
 502
 503     error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
 504                               (HsLit (HsString (_PK_ error_msg)))
 505
 506     error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|",
 507                             ppr (PprForUser opt_PprUserLength) sel_id
 508                 ])
 509 \end{code}
 510
 511
 512
 513 %************************************************************************
 514 %*                                                                      *
 515 \subsection{Type-checking specialise instance pragmas}
 516 %*                                                                      *
 517 %************************************************************************
 518
 519 \begin{code}
 520 {- LATER
 521 tcSpecInstSigs :: E -> CE -> TCE
 522                -> Bag InstInfo          -- inst decls seen (declared and derived)
 523                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 524                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 525
 526 tcSpecInstSigs e ce tce inst_infos []
 527   = returnTc emptyBag
 528
 529 tcSpecInstSigs e ce tce inst_infos sigs
 530   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 531     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 532     returnTc spec_inst_infos
 533   where
 534     tc_inst_spec_sigs inst_mapper []
 535       = returnNF_Tc emptyBag
 536     tc_inst_spec_sigs inst_mapper (sig:sigs)
 537       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 538         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 539         returnNF_Tc (info_sig `unionBags` info_sigs)
 540
 541 tcSpecInstSig :: E -> CE -> TCE
 542               -> Bag InstInfo
 543               -> InstanceMapper
 544               -> RenamedSpecInstSig
 545               -> NF_TcM (Bag InstInfo)
 546
 547 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 548   = recoverTc emptyBag                  (
 549     tcAddSrcLoc src_loc                 (
 550     let
 551         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 552
 553         -- Make some new type variables, named as in the specialised instance type
 554         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 555         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 556     in
 557     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 558                                 `thenTc` \ inst_ty ->
 559     let
 560         maybe_tycon = case maybeAppDataTyCon inst_ty of
 561                          Just (tc,_,_) -> Just tc
 562                          Nothing       -> Nothing
 563
 564         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 565     in
 566         -- Check that we have a local instance declaration to specialise
 567     checkMaybeTc maybe_unspec_inst
 568             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 569
 570         -- Create tvs to substitute for tmpls while simplifying the context
 571     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 572     let
 573         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 574                        _ _ binds _ uprag) = maybe_unspec_inst
 575
 576         subst = case matchTy unspec_inst_ty inst_ty of
 577                      Just subst -> subst
 578                      Nothing    -> panic "tcSpecInstSig:matchTy"
 579
 580         subst_theta    = instantiateThetaTy subst unspec_theta
 581         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 582
 583         mk_spec_origin clas ty
 584           = InstanceSpecOrigin inst_mapper clas ty src_loc
 585         -- I'm VERY SUSPICIOUS ABOUT THIS
 586         -- the inst-mapper is in a knot at this point so it's no good
 587         -- looking at it in tcSimplify...
 588     in
 589     tcSimplifyThetas mk_spec_origin subst_tv_theta
 590                                 `thenTc` \ simpl_tv_theta ->
 591     let
 592         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 593
 594         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 595         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 596     in
 597     mkInstanceRelatedIds
 598                          clas inst_tmpls inst_ty simpl_theta uprag
 599                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 600
 601     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 602     (if sw_chkr SpecialiseTrace then
 603         pprTrace "Specialised Instance: "
 604         (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta,
 605                           if null simpl_theta then empty else ptext SLIT("=>"),
 606                           ppr PprDebug clas,
 607                           pprParendGenType PprDebug inst_ty],
 608                    hsep [ptext SLIT("        derived from:"),
 609                           if null unspec_theta then empty else ppr PprDebug unspec_theta,
 610                           if null unspec_theta then empty else ptext SLIT("=>"),
 611                           ppr PprDebug clas,
 612                           pprParendGenType PprDebug unspec_inst_ty]])
 613     else id) (
 614
 615     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 616                                 dfun_theta dfun_id
 617                                 binds src_loc uprag))
 618     )))
 619
 620
 621 lookup_unspec_inst clas maybe_tycon inst_infos
 622   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 623         []       -> Nothing
 624         (info:_) -> Just info
 625   where
 626     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 627       = from_here && clas == inst_clas &&
 628         match_ty inst_ty && is_plain_instance inst_ty
 629
 630     match_inst_ty = case maybe_tycon of
 631                       Just tycon -> match_tycon tycon
 632                       Nothing    -> match_fun
 633
 634     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 635           Just (inst_tc,_,_) -> tycon == inst_tc
 636           Nothing            -> False
 637
 638     match_fun inst_ty = isFunType inst_ty
 639
 640
 641 is_plain_instance inst_ty
 642   = case (maybeAppDataTyCon inst_ty) of
 643       Just (_,tys,_) -> all isTyVarTemplateTy tys
 644       Nothing        -> case maybeUnpackFunTy inst_ty of
 645                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 646                           Nothing         -> error "TcInstDecls:is_plain_instance"
 647 -}
 648 \end{code}
 649
 650
 651 Checking for a decent instance type
 652 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 653 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 654 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 655
 656 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 657 flag is on, or (2)~the instance is imported (they must have been
 658 compiled elsewhere). In these cases, we let them go through anyway.
 659
 660 We can also have instances for functions: @instance Foo (a -> b) ...@.
 661
 662 \begin{code}
 663 scrutiniseInstanceType dfun_name clas inst_tau
 664         -- TYCON CHECK
 665   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 666   = failTc (instTypeErr inst_tau)
 667
 668         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 669   | not (isLocallyDefined dfun_name)
 670   = returnTc (inst_tycon,arg_tys)
 671
 672         -- TYVARS CHECK
 673   | not (opt_GlasgowExts ||
 674          (all isTyVarTy arg_tys && null tyvar_dups)
 675     )
 676   = failTc (instTypeErr inst_tau)
 677
 678         -- DERIVING CHECK
 679         -- It is obviously illegal to have an explicit instance
 680         -- for something that we are also planning to `derive'
 681         -- Though we can have an explicit instance which is more
 682         -- specific than the derived instance
 683   | clas `elem` (derivedClasses inst_tycon)
 684     && all isTyVarTy arg_tys
 685   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 686
 687   |     -- CCALL CHECK
 688         -- A user declaration of a CCallable/CReturnable instance
 689         -- must be for a "boxed primitive" type.
 690     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 691     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 692   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 693
 694   | otherwise
 695   = returnTc (inst_tycon,arg_tys)
 696
 697   where
 698     (possible_tycon, arg_tys) = splitAppTys inst_tau
 699     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 700     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 701     (_, tyvar_dups)           = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
 702
 703 -- These conditions come directly from what the DsCCall is capable of.
 704 -- Totally grotesque.  Green card should solve this.
 705
 706 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 707                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 708                       ty `eqTy` stringTy ||
 709                       byte_arr_thing
 710   where
 711     byte_arr_thing = case maybeAppDataTyCon ty of
 712                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 713                                 length data_con_arg_tys == 2 &&
 714                                 maybeToBool maybe_arg2_tycon &&
 715                                 (arg2_tycon == byteArrayPrimTyCon ||
 716                                  arg2_tycon == mutableByteArrayPrimTyCon)
 717                              where
 718                                 data_con_arg_tys = dataConArgTys data_con ty_args
 719                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 720                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 721                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 722
 723                         other -> False
 724
 725 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 726                         -- Or, a data type with a single nullary constructor
 727                       case (maybeAppDataTyCon ty) of
 728                         Just (tycon, tys_applied, [data_con])
 729                                 -> isNullaryDataCon data_con
 730                         other -> False
 731 \end{code}
 732
 733 \begin{code}
 734
 735 instTypeErr ty sty
 736   = case ty of
 737       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
 738       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
 739       other        -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
 740   where
 741     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 742
 743 instBndrErr bndr clas sty
 744   = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
 745
 746 derivingWhenInstanceExistsErr clas tycon sty
 747   = hang (hsep [ptext SLIT("Deriving class"),
 748                        ppr sty clas,
 749                        ptext SLIT("type"), ppr sty tycon])
 750          4 (ptext SLIT("when an explicit instance exists"))
 751
 752 nonBoxedPrimCCallErr clas inst_ty sty
 753   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 754          4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
 755                         ppr sty inst_ty])
 756
 757 omittedMethodWarn sel_id clas sty
 758   = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id,
 759          ptext SLIT("in an instance declaration for") <+> ppr sty clas]
 760
 761 instMethodNotInClassErr occ clas sty
 762   = hang (ptext SLIT("Instance mentions a method not in the class"))
 763          4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
 764                        ppr sty occ])
 765
 766 patMonoBindsCtxt pbind sty
 767   = hang (ptext SLIT("In a pattern binding:"))
 768          4 (ppr sty pbind)
 769
 770 methodSigCtxt name ty sty
 771   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 772                        ppr sty name, ptext SLIT("to its signature :") ])
 773          4 (ppr sty ty)
 774
 775 bindSigCtxt sty
 776   = ptext SLIT("When checking methods of an instance declaration")
 777
 778 superClassSigCtxt sty
 779   = ptext SLIT("When checking superclass constraints of an instance declaration")
 780 \end{code}