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, badMethodErr )
  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 that all the method bindings come from this class
 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 (badMethodErr bndr clas)
 392         sel_names = map getOccName op_sel_ids
 393     in
 394     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))      `thenTc_`
 395
 396           -- Type check the method bindings themselves
 397     tcExtendGlobalTyVars inst_tyvars_set' (
 398         tcExtendGlobalValEnv (catMaybes defm_ids) $
 399                 -- Default-method Ids may be mentioned in synthesised RHSs
 400
 401         mapAndUnzip3Tc (tcInstMethodBind clas inst_ty' monobinds)
 402                        (op_sel_ids `zip` defm_ids)
 403     )                   `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 404
 405         -- Check the overloading constraints of the methods and superclasses
 406     let
 407         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 408         avail_insts      -- These insts are in scope; quite a few, eh?
 409           = this_dict `plusLIE` dfun_arg_dicts `plusLIE`  unionManyBags meth_lies
 410     in
 411     tcAddErrCtxt bindSigCtxt (
 412         tcSimplifyAndCheck
 413                  inst_tyvars_set'                       -- Local tyvars
 414                  avail_insts
 415                  (sc_dicts `unionBags`
 416                   unionManyBags insts_needed_s)         -- Need to get defns for all these
 417     )                                    `thenTc` \ (const_lie, super_binds) ->
 418
 419         -- Check that we *could* construct the superclass dictionaries,
 420         -- even though we are *actually* going to pass the superclass dicts in;
 421         -- the check ensures that the caller will never have a problem building
 422         -- them.
 423     tcAddErrCtxt superClassSigCtxt (
 424         tcSimplifyAndCheck
 425                  inst_tyvars_set'               -- Local tyvars
 426                  inst_decl_dicts                -- The instance dictionaries available
 427                  sc_dicts                       -- The superclass dicationaries reqd
 428     )                                   `thenTc_`
 429                                                 -- Ignore the result; we're only doing
 430                                                 -- this to make sure it can be done.
 431
 432         -- Create the result bindings
 433     let
 434         dict_bind    = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 435         method_binds = andMonoBinds method_binds_s
 436
 437         main_bind
 438           = AbsBinds
 439                  inst_tyvars'
 440                  dfun_arg_dicts_ids
 441                  [(inst_tyvars', RealId dfun_id, this_dict_id)]
 442                  (super_binds   `AndMonoBinds`
 443                   method_binds  `AndMonoBinds`
 444                   dict_bind)
 445     in
 446     returnTc (const_lie `plusLIE` spec_lie,
 447               main_bind `AndMonoBinds` spec_binds)
 448 \end{code}
 449
 450
 451 %************************************************************************
 452 %*                                                                      *
 453 \subsection{Processing each method}
 454 %*                                                                      *
 455 %************************************************************************
 456
 457 \begin{code}
 458 tcInstMethodBind
 459         :: Class
 460         -> TcType s                                     -- Instance type
 461         -> RenamedMonoBinds                             -- Method binding
 462         -> (Id, Maybe Id)                               -- Selector id and default-method id
 463         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 464
 465 tcInstMethodBind clas inst_ty meth_binds (sel_id, maybe_dm_id)
 466   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 467     tcGetUnique                 `thenNF_Tc` \ uniq ->
 468     let
 469         meth_occ          = getOccName sel_id
 470         default_meth_name = mkLocalName uniq meth_occ loc
 471         maybe_meth_bind   = find meth_occ meth_binds
 472         the_meth_bind     = case maybe_meth_bind of
 473                                   Just stuff -> stuff
 474                                   Nothing    -> mk_default_bind default_meth_name
 475     in
 476
 477         -- Warn if no method binding, only if -fwarn-missing-methods
 478
 479     warnTc (opt_WarnMissingMethods &&
 480             not (maybeToBool maybe_meth_bind) &&
 481             not (maybeToBool maybe_dm_id))
 482         (omittedMethodWarn sel_id clas)         `thenNF_Tc_`
 483
 484         -- Typecheck the method binding
 485     tcMethodBind clas origin inst_ty sel_id the_meth_bind
 486   where
 487     origin = InstanceDeclOrigin         -- Poor
 488
 489     find occ EmptyMonoBinds       = Nothing
 490     find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
 491
 492     find occ b@(FunMonoBind op_name _ _ _)          | nameOccName op_name == occ = Just b
 493                                                     | otherwise           = Nothing
 494     find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
 495                                                     | otherwise           = Nothing
 496     find 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         -- To verify that a user declaration of a CCallable/CReturnable
 694         -- instance is OK, we must be able to see the constructor(s)
 695         -- of the instance type (see next guard.)
 696         --
 697         -- We flag this separately to give a more precise error msg.
 698         --
 699     (uniqueOf clas == cCallableClassKey   && not constructors_visible) ||
 700     (uniqueOf clas == cReturnableClassKey && not constructors_visible)
 701   = failTc (invisibleDataConPrimCCallErr clas inst_tau)
 702
 703   |     -- CCALL CHECK
 704         -- A user declaration of a CCallable/CReturnable instance
 705         -- must be for a "boxed primitive" type.
 706     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 707     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 708   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 709
 710   | otherwise
 711   = returnTc (inst_tycon,arg_tys)
 712
 713   where
 714     (possible_tycon, arg_tys) = splitAppTys inst_tau
 715     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 716     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 717     (_, tyvar_dups)           = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
 718
 719     constructors_visible      =
 720         case maybeAppDataTyCon inst_tau of
 721            Just (_,_,[])   -> False
 722            everything_else -> True
 723
 724 -- These conditions come directly from what the DsCCall is capable of.
 725 -- Totally grotesque.  Green card should solve this.
 726
 727 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 728                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 729                       ty `eqTy` stringTy ||
 730                       byte_arr_thing
 731   where
 732     byte_arr_thing = case maybeAppDataTyCon ty of
 733                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 734                                 length data_con_arg_tys == 2 &&
 735                                 maybeToBool maybe_arg2_tycon &&
 736                                 (arg2_tycon == byteArrayPrimTyCon ||
 737                                  arg2_tycon == mutableByteArrayPrimTyCon)
 738                              where
 739                                 data_con_arg_tys = dataConArgTys data_con ty_args
 740                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 741                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 742                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 743
 744                         other -> False
 745
 746 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 747                         -- Or, a data type with a single nullary constructor
 748                       case (maybeAppDataTyCon ty) of
 749                         Just (tycon, tys_applied, [data_con])
 750                                 -> isNullaryDataCon data_con
 751                         other -> False
 752 \end{code}
 753
 754 \begin{code}
 755
 756 instTypeErr ty sty
 757   = case ty of
 758       SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
 759       TyVarTy tv   -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
 760       other        -> sep [ptext SLIT("The type"), nest 4 (ppr sty ty), rest_of_msg]
 761   where
 762     rest_of_msg = ptext SLIT("cannot be used as an instance type")
 763
 764 derivingWhenInstanceExistsErr clas tycon sty
 765   = hang (hsep [ptext SLIT("Deriving class"),
 766                        ppr sty clas,
 767                        ptext SLIT("type"), ppr sty tycon])
 768          4 (ptext SLIT("when an explicit instance exists"))
 769
 770 nonBoxedPrimCCallErr clas inst_ty sty
 771   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 772          4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
 773                         ppr sty inst_ty])
 774
 775 {-
 776   Declaring CCallable & CReturnable instances in a module different
 777   from where the type was defined. Caused by importing data type
 778   abstractly (either programmatically or by the renamer being over-eager
 779   in its pruning.)
 780 -}
 781 invisibleDataConPrimCCallErr clas inst_ty sty
 782   = hang (hsep [(ppr sty inst_ty <> ptext SLIT("s constructors not visible when checking")),
 783                 ppr sty clas, ptext SLIT("instance")])
 784         4 (hsep [ptext SLIT("(Try either importing"), ppr sty inst_ty,
 785                  ptext SLIT("non-abstractly or compile using -fno-prune-tydecls ..)")])
 786
 787 omittedMethodWarn sel_id clas sty
 788   = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> ppr sty sel_id,
 789          ptext SLIT("in an instance declaration for") <+> ppr sty clas]
 790
 791 instMethodNotInClassErr occ clas sty
 792   = hang (ptext SLIT("Instance mentions a method not in the class"))
 793          4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
 794                        ppr sty occ])
 795
 796 patMonoBindsCtxt pbind sty
 797   = hang (ptext SLIT("In a pattern binding:"))
 798          4 (ppr sty pbind)
 799
 800 methodSigCtxt name ty sty
 801   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 802                        ppr sty name, ptext SLIT("to its signature :") ])
 803          4 (ppr sty ty)
 804
 805 bindSigCtxt sty
 806   = ptext SLIT("When checking methods of an instance declaration")
 807
 808 superClassSigCtxt sty
 809   = ptext SLIT("When checking superclass constraints of an instance declaration")
 810 \end{code}