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