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         tcMethodBind
  13     ) where
  14
  15
  16 IMP_Ubiq()
  17
  18 import HsSyn            ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
  19                           FixityDecl, IfaceSig, Sig(..),
  20                           SpecInstSig(..), HsBinds(..),
  21                           MonoBinds(..), GRHSsAndBinds(..), GRHS(..), Match,
  22                           InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  23                           Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity,
  24                           HsType(..), HsTyVar,
  25                           SYN_IE(RecFlag), recursive, nonRecursive, collectMonoBinders,
  26                           andMonoBinds
  27                         )
  28 import RnHsSyn          ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
  29                           SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), SYN_IE(RenamedHsExpr),
  30                           SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
  31                         )
  32 import TcHsSyn          ( SYN_IE(TcHsBinds),
  33                           SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
  34                           mkHsTyLam, mkHsTyApp,
  35                           mkHsDictLam, mkHsDictApp )
  36
  37 import TcBinds          ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..), checkSigTyVars )
  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, getOccString, occNameString, moduleString, getSrcLoc,
  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 (tcMethodBind 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 tcMethodBind
 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 tcMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
 464   = newMethod origin (RealId sel_id) [inst_ty]  `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
 465     tcInstSigTcType (idType local_meth_id)      `thenNF_Tc` \ (tyvars', rho_ty') ->
 466     let
 467         meth_name    = getName local_meth_id
 468
 469         maybe_meth_bind      = go (getOccName sel_id) meth_binds
 470         (bndr_name, op_bind) = case maybe_meth_bind of
 471                                   Just stuff -> stuff
 472                                   Nothing    -> (meth_name, mk_default_bind meth_name)
 473
 474         (theta', tau')  = splitRhoTy rho_ty'
 475         sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' noSrcLoc
 476     in
 477
 478         -- Warn if no method binding
 479     warnTc (not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id))
 480            (omittedMethodWarn sel_id clas)              `thenNF_Tc_`
 481
 482     tcBindWithSigs [bndr_name] op_bind [sig_info]
 483                    nonRecursive (\_ -> NoPragmaInfo)    `thenTc` \ (binds, insts, _) ->
 484
 485     returnTc (binds, insts, meth)
 486   where
 487     origin = InstanceDeclOrigin         -- Poor
 488
 489     go occ EmptyMonoBinds       = Nothing
 490     go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2
 491
 492     go occ b@(FunMonoBind op_name _ _ locn)          | nameOccName op_name == occ = Just (op_name, b)
 493                                                      | otherwise                  = Nothing
 494     go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
 495                                                      | otherwise                  = Nothing
 496     go occ other = panic "Urk! Bad instance method binding"
 497
 498
 499     mk_default_bind local_meth_name
 500       = PatMonoBind (VarPatIn local_meth_name)
 501                     (GRHSsAndBindsIn [OtherwiseGRHS default_expr noSrcLoc] EmptyBinds)
 502                     noSrcLoc
 503
 504     default_expr = case maybe_dm_id of
 505                         Just dm_id -> HsVar (getName dm_id)     -- There's a default method
 506                         Nothing    -> error_expr                -- No default method
 507
 508     error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
 509                               (HsLit (HsString (_PK_ error_msg)))
 510
 511     error_msg = show (hcat [ppr (PprForUser opt_PprUserLength) (getSrcLoc sel_id), text "|",
 512                             ppr (PprForUser opt_PprUserLength) sel_id
 513                 ])
 514 \end{code}
 515
 516
 517
 518 %************************************************************************
 519 %*                                                                      *
 520 \subsection{Type-checking specialise instance pragmas}
 521 %*                                                                      *
 522 %************************************************************************
 523
 524 \begin{code}
 525 {- LATER
 526 tcSpecInstSigs :: E -> CE -> TCE
 527                -> Bag InstInfo          -- inst decls seen (declared and derived)
 528                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 529                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 530
 531 tcSpecInstSigs e ce tce inst_infos []
 532   = returnTc emptyBag
 533
 534 tcSpecInstSigs e ce tce inst_infos sigs
 535   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 536     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 537     returnTc spec_inst_infos
 538   where
 539     tc_inst_spec_sigs inst_mapper []
 540       = returnNF_Tc emptyBag
 541     tc_inst_spec_sigs inst_mapper (sig:sigs)
 542       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 543         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 544         returnNF_Tc (info_sig `unionBags` info_sigs)
 545
 546 tcSpecInstSig :: E -> CE -> TCE
 547               -> Bag InstInfo
 548               -> InstanceMapper
 549               -> RenamedSpecInstSig
 550               -> NF_TcM (Bag InstInfo)
 551
 552 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 553   = recoverTc emptyBag                  (
 554     tcAddSrcLoc src_loc                 (
 555     let
 556         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 557
 558         -- Make some new type variables, named as in the specialised instance type
 559         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 560         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 561     in
 562     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 563                                 `thenTc` \ inst_ty ->
 564     let
 565         maybe_tycon = case maybeAppDataTyCon inst_ty of
 566                          Just (tc,_,_) -> Just tc
 567                          Nothing       -> Nothing
 568
 569         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 570     in
 571         -- Check that we have a local instance declaration to specialise
 572     checkMaybeTc maybe_unspec_inst
 573             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 574
 575         -- Create tvs to substitute for tmpls while simplifying the context
 576     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 577     let
 578         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 579                        _ _ binds _ uprag) = maybe_unspec_inst
 580
 581         subst = case matchTy unspec_inst_ty inst_ty of
 582                      Just subst -> subst
 583                      Nothing    -> panic "tcSpecInstSig:matchTy"
 584
 585         subst_theta    = instantiateThetaTy subst unspec_theta
 586         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 587
 588         mk_spec_origin clas ty
 589           = InstanceSpecOrigin inst_mapper clas ty src_loc
 590         -- I'm VERY SUSPICIOUS ABOUT THIS
 591         -- the inst-mapper is in a knot at this point so it's no good
 592         -- looking at it in tcSimplify...
 593     in
 594     tcSimplifyThetas mk_spec_origin subst_tv_theta
 595                                 `thenTc` \ simpl_tv_theta ->
 596     let
 597         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 598
 599         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 600         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 601     in
 602     mkInstanceRelatedIds
 603                          clas inst_tmpls inst_ty simpl_theta uprag
 604                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 605
 606     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 607     (if sw_chkr SpecialiseTrace then
 608         pprTrace "Specialised Instance: "
 609         (vcat [hsep [if null simpl_theta then empty else ppr PprDebug simpl_theta,
 610                           if null simpl_theta then empty else ptext SLIT("=>"),
 611                           ppr PprDebug clas,
 612                           pprParendGenType PprDebug inst_ty],
 613                    hsep [ptext SLIT("        derived from:"),
 614                           if null unspec_theta then empty else ppr PprDebug unspec_theta,
 615                           if null unspec_theta then empty else ptext SLIT("=>"),
 616                           ppr PprDebug clas,
 617                           pprParendGenType PprDebug unspec_inst_ty]])
 618     else id) (
 619
 620     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 621                                 dfun_theta dfun_id
 622                                 binds src_loc uprag))
 623     )))
 624
 625
 626 lookup_unspec_inst clas maybe_tycon inst_infos
 627   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 628         []       -> Nothing
 629         (info:_) -> Just info
 630   where
 631     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 632       = from_here && clas == inst_clas &&
 633         match_ty inst_ty && is_plain_instance inst_ty
 634
 635     match_inst_ty = case maybe_tycon of
 636                       Just tycon -> match_tycon tycon
 637                       Nothing    -> match_fun
 638
 639     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 640           Just (inst_tc,_,_) -> tycon == inst_tc
 641           Nothing            -> False
 642
 643     match_fun inst_ty = isFunType inst_ty
 644
 645
 646 is_plain_instance inst_ty
 647   = case (maybeAppDataTyCon inst_ty) of
 648       Just (_,tys,_) -> all isTyVarTemplateTy tys
 649       Nothing        -> case maybeUnpackFunTy inst_ty of
 650                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 651                           Nothing         -> error "TcInstDecls:is_plain_instance"
 652 -}
 653 \end{code}
 654
 655
 656 Checking for a decent instance type
 657 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 658 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 659 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 660
 661 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 662 flag is on, or (2)~the instance is imported (they must have been
 663 compiled elsewhere). In these cases, we let them go through anyway.
 664
 665 We can also have instances for functions: @instance Foo (a -> b) ...@.
 666
 667 \begin{code}
 668 scrutiniseInstanceType dfun_name clas inst_tau
 669         -- TYCON CHECK
 670   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 671   = failTc (instTypeErr inst_tau)
 672
 673         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 674   | not (isLocallyDefined dfun_name)
 675   = returnTc (inst_tycon,arg_tys)
 676
 677         -- TYVARS CHECK
 678   | not (opt_GlasgowExts ||
 679          (all isTyVarTy arg_tys && null tyvar_dups)
 680     )
 681   = failTc (instTypeErr inst_tau)
 682
 683         -- DERIVING CHECK
 684         -- It is obviously illegal to have an explicit instance
 685         -- for something that we are also planning to `derive'
 686         -- Though we can have an explicit instance which is more
 687         -- specific than the derived instance
 688   | clas `elem` (derivedClasses inst_tycon)
 689     && all isTyVarTy arg_tys
 690   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 691
 692   |     -- CCALL CHECK
 693         -- A user declaration of a CCallable/CReturnable instance
 694         -- must be for a "boxed primitive" type.
 695     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 696     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 697   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 698
 699   | otherwise
 700   = returnTc (inst_tycon,arg_tys)
 701
 702   where
 703     (possible_tycon, arg_tys) = splitAppTys inst_tau
 704     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 705     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 706     (_, tyvar_dups)           = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
 707
 708 -- These conditions come directly from what the DsCCall is capable of.
 709 -- Totally grotesque.  Green card should solve this.
 710
 711 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 712                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 713                       ty `eqTy` stringTy ||
 714                       byte_arr_thing
 715   where
 716     byte_arr_thing = case maybeAppDataTyCon ty of
 717                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 718                                 length data_con_arg_tys == 2 &&
 719                                 maybeToBool maybe_arg2_tycon &&
 720                                 (arg2_tycon == byteArrayPrimTyCon ||
 721                                  arg2_tycon == mutableByteArrayPrimTyCon)
 722                              where
 723                                 data_con_arg_tys = dataConArgTys data_con ty_args
 724                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 725                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 726                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 727
 728                         other -> False
 729
 730 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 731                         -- Or, a data type with a single nullary constructor
 732                       case (maybeAppDataTyCon ty) of
 733                         Just (tycon, tys_applied, [data_con])
 734                                 -> isNullaryDataCon data_con
 735                         other -> False
 736 \end{code}
 737
 738 \begin{code}
 739
 740 instTypeErr ty sty
 741   = case ty of
 742       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
 743       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
 744       other        -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
 745   where
 746     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 747
 748 instBndrErr bndr clas sty
 749   = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
 750
 751 derivingWhenInstanceExistsErr clas tycon sty
 752   = hang (hsep [ptext SLIT("Deriving class"),
 753                        ppr sty clas,
 754                        ptext SLIT("type"), ppr sty tycon])
 755          4 (ptext SLIT("when an explicit instance exists"))
 756
 757 nonBoxedPrimCCallErr clas inst_ty sty
 758   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 759          4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
 760                         ppr sty inst_ty])
 761
 762 omittedMethodWarn sel_id clas sty
 763   = sep [ptext SLIT("No explicit method nor default method for") <+> ppr sty sel_id,
 764          ptext SLIT("in an instance declaration for") <+> ppr sty clas]
 765
 766 instMethodNotInClassErr occ clas sty
 767   = hang (ptext SLIT("Instance mentions a method not in the class"))
 768          4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
 769                        ppr sty occ])
 770
 771 patMonoBindsCtxt pbind sty
 772   = hang (ptext SLIT("In a pattern binding:"))
 773          4 (ppr sty pbind)
 774
 775 methodSigCtxt name ty sty
 776   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 777                        ppr sty name, ptext SLIT("to its signature :") ])
 778          4 (ppr sty ty)
 779
 780 bindSigCtxt sty
 781   = ptext SLIT("When checking methods of an instance declaration")
 782
 783 superClassSigCtxt sty
 784   = ptext SLIT("When checking superclass constraints of an instance declaration")
 785 \end{code}