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 module TcInstDcls (
   8         tcInstDecls1,
   9         tcInstDecls2
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import HsSyn            ( HsDecl(..), InstDecl(..), HsType(..),
  15                           HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..),
  16                           HsExpr(..), InPat(..), HsLit(..),
  17                           unguardedRHS,
  18                           collectMonoBinders, andMonoBinds
  19                         )
  20 import RnHsSyn          ( RenamedHsBinds, RenamedMonoBinds,
  21                           RenamedInstDecl, RenamedFixityDecl, RenamedHsExpr,
  22                           RenamedSig, RenamedSpecInstSig, RenamedHsDecl
  23                         )
  24 import TcHsSyn          ( TcHsBinds,
  25                           TcMonoBinds, TcExpr, TcIdOcc(..), TcIdBndr,
  26                           tcIdType, maybeBoxedPrimType,
  27                           mkHsTyLam, mkHsTyApp,
  28                           mkHsDictLam, mkHsDictApp )
  29
  30 import TcBinds          ( tcPragmaSigs, sigThetaCtxt )
  31 import TcClassDcl       ( tcMethodBind, badMethodErr )
  32 import TcMonad
  33 import RnMonad          ( RnNameSupply )
  34 import Inst             ( Inst, InstOrigin(..), InstanceMapper,
  35                           instToId, newDicts, newMethod, LIE, emptyLIE, plusLIE )
  36 import PragmaInfo       ( PragmaInfo(..) )
  37 import TcDeriv          ( tcDeriving )
  38 import TcEnv            ( tcLookupClass, newLocalId, tcGetGlobalTyVars,
  39                           tcExtendGlobalValEnv, tcAddImportedIdInfo
  40                         )
  41 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs, classDataCon )
  42 import TcKind           ( TcKind, unifyKind )
  43 import TcMatches        ( tcMatchesFun )
  44 import TcMonoType       ( tcTyVarScope, tcContext, tcHsTypeKind, tcHsType )
  45 import TcSimplify       ( tcSimplifyAndCheck )
  46 import TcType           ( TcType, TcTyVar, TcTyVarSet,
  47                           zonkSigTyVar,
  48                           tcInstSigTyVars, tcInstType, tcInstSigTcType,
  49                           tcInstTheta, tcInstTcType
  50                         )
  51 import Unify            ( unifyTauTy, unifyTauTyLists )
  52
  53
  54 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  55                           concatBag, foldBag, bagToList, listToBag,
  56                           Bag
  57                         )
  58 import CmdLineOpts      ( opt_GlasgowExts,
  59                           opt_SpecialiseOverloaded, opt_WarnMissingMethods
  60                         )
  61 import Class            ( classBigSig, classTyCon, Class )
  62 import Id               ( idType, replacePragmaInfo,
  63                           isNullaryDataCon, dataConArgTys, Id )
  64 import ListSetOps       ( minusList )
  65 import Maybes           ( maybeToBool, expectJust, seqMaybe, catMaybes )
  66 import Name             ( nameOccName, getSrcLoc, mkLocalName,
  67                           isLocallyDefined, Module,
  68                           NamedThing(..)
  69                         )
  70 import PrelVals         ( nO_METHOD_BINDING_ERROR_ID )
  71 import PprType          ( pprParendGenType,  pprConstraint )
  72 import SrcLoc           ( SrcLoc, noSrcLoc )
  73 import TyCon            ( tyConDataCons, isSynTyCon, isDataTyCon, tyConDerivings )
  74 import Type             ( Type, ThetaType, mkTyVarTys, isUnpointedType,
  75                           splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
  76                           splitTyConApp_maybe, getTyVar, splitDictTy_maybe,
  77                           splitAlgTyConApp_maybe, splitRhoTy, isSynTy,
  78                           tyVarsOfTypes
  79                         )
  80 import TyVar            ( zipTyVarEnv, mkTyVarSet, tyVarSetToList, TyVar )
  81 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  82 import TysWiredIn       ( stringTy )
  83 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
  84 import Util             ( zipEqual, removeDups )
  85 import Outputable
  86 \end{code}
  87
  88 Typechecking instance declarations is done in two passes. The first
  89 pass, made by @tcInstDecls1@, collects information to be used in the
  90 second pass.
  91
  92 This pre-processed info includes the as-yet-unprocessed bindings
  93 inside the instance declaration.  These are type-checked in the second
  94 pass, when the class-instance envs and GVE contain all the info from
  95 all the instance and value decls.  Indeed that's the reason we need
  96 two passes over the instance decls.
  97
  98
  99 Here is the overall algorithm.
 100 Assume that we have an instance declaration
 101
 102     instance c => k (t tvs) where b
 103
 104 \begin{enumerate}
 105 \item
 106 $LIE_c$ is the LIE for the context of class $c$
 107 \item
 108 $betas_bar$ is the free variables in the class method type, excluding the
 109    class variable
 110 \item
 111 $LIE_cop$ is the LIE constraining a particular class method
 112 \item
 113 $tau_cop$ is the tau type of a class method
 114 \item
 115 $LIE_i$ is the LIE for the context of instance $i$
 116 \item
 117 $X$ is the instance constructor tycon
 118 \item
 119 $gammas_bar$ is the set of type variables of the instance
 120 \item
 121 $LIE_iop$ is the LIE for a particular class method instance
 122 \item
 123 $tau_iop$ is the tau type for this instance of a class method
 124 \item
 125 $alpha$ is the class variable
 126 \item
 127 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 128 \item
 129 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 130 \end{enumerate}
 131
 132 ToDo: Update the list above with names actually in the code.
 133
 134 \begin{enumerate}
 135 \item
 136 First, make the LIEs for the class and instance contexts, which means
 137 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 138 and make LIElistI and LIEI.
 139 \item
 140 Then process each method in turn.
 141 \item
 142 order the instance methods according to the ordering of the class methods
 143 \item
 144 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 145 \item
 146 Create final dictionary function from bindings generated already
 147 \begin{pseudocode}
 148 df = lambda inst_tyvars
 149        lambda LIEI
 150          let Bop1
 151              Bop2
 152              ...
 153              Bopn
 154          and dbinds_super
 155               in <op1,op2,...,opn,sd1,...,sdm>
 156 \end{pseudocode}
 157 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 158 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 159 \end{enumerate}
 160
 161 \begin{code}
 162 tcInstDecls1 :: TcEnv s                 -- Contains IdInfo for dfun ids
 163              -> [RenamedHsDecl]
 164              -> Module                  -- module name for deriving
 165              -> RnNameSupply                    -- for renaming derivings
 166              -> TcM s (Bag InstInfo,
 167                        RenamedHsBinds,
 168                        SDoc)
 169
 170 tcInstDecls1 unf_env decls mod_name rn_name_supply
 171   =     -- Do the ordinary instance declarations
 172     mapNF_Tc (tcInstDecl1 unf_env mod_name)
 173              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 174     let
 175         decl_inst_info = unionManyBags inst_info_bags
 176     in
 177         -- Handle "derived" instances; note that we only do derivings
 178         -- for things in this module; we ignore deriving decls from
 179         -- interfaces!
 180     tcDeriving mod_name rn_name_supply decl_inst_info
 181                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 182
 183     let
 184         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 185     in
 186     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 187
 188
 189 tcInstDecl1 :: TcEnv s -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 190
 191 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 192   =     -- Prime error recovery, set source location
 193     recoverNF_Tc (returnNF_Tc emptyBag) $
 194     tcAddSrcLoc src_loc                 $
 195
 196         -- Type-check all the stuff before the "where"
 197     tcHsType poly_ty                    `thenTc` \ poly_ty' ->
 198     let
 199         (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
 200         (clas, inst_tys)         = case splitDictTy_maybe dict_ty of
 201                                      Nothing   -> pprPanic "tcInstDecl1" (ppr poly_ty)
 202                                      Just pair -> pair
 203     in
 204
 205         -- Check for respectable instance type
 206     scrutiniseInstanceType clas inst_tys        `thenTc_`
 207
 208         -- Make the dfun id and constant-method ids
 209     let
 210         (dfun_id, dfun_theta) = mkInstanceRelatedIds dfun_name
 211                                          clas tyvars inst_tys theta
 212         -- Add info from interface file
 213         final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
 214     in
 215     returnTc (unitBag (InstInfo clas tyvars inst_tys theta
 216                                 dfun_theta final_dfun_id
 217                                 binds src_loc uprags))
 218 \end{code}
 219
 220
 221 %************************************************************************
 222 %*                                                                      *
 223 \subsection{Type-checking instance declarations, pass 2}
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 \begin{code}
 228 tcInstDecls2 :: Bag InstInfo
 229              -> NF_TcM s (LIE s, TcMonoBinds s)
 230
 231 tcInstDecls2 inst_decls
 232   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 233   where
 234     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 235                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 236                       returnNF_Tc (lie1 `plusLIE` lie2,
 237                                    binds1 `AndMonoBinds` binds2)
 238 \end{code}
 239
 240
 241 ======= New documentation starts here (Sept 92)  ==============
 242
 243 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 244 the dictionary function for this instance declaration.  For example
 245 \begin{verbatim}
 246         instance Foo a => Foo [a] where
 247                 op1 x = ...
 248                 op2 y = ...
 249 \end{verbatim}
 250 might generate something like
 251 \begin{verbatim}
 252         dfun.Foo.List dFoo_a = let op1 x = ...
 253                                    op2 y = ...
 254                                in
 255                                    Dict [op1, op2]
 256 \end{verbatim}
 257
 258 HOWEVER, if the instance decl has no context, then it returns a
 259 bigger @HsBinds@ with declarations for each method.  For example
 260 \begin{verbatim}
 261         instance Foo [a] where
 262                 op1 x = ...
 263                 op2 y = ...
 264 \end{verbatim}
 265 might produce
 266 \begin{verbatim}
 267         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 268         const.Foo.op1.List a x = ...
 269         const.Foo.op2.List a y = ...
 270 \end{verbatim}
 271 This group may be mutually recursive, because (for example) there may
 272 be no method supplied for op2 in which case we'll get
 273 \begin{verbatim}
 274         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 275 \end{verbatim}
 276 that is, the default method applied to the dictionary at this type.
 277
 278 What we actually produce in either case is:
 279
 280         AbsBinds [a] [dfun_theta_dicts]
 281                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 282                  { d = (sd1,sd2, ..., op1, op2, ...)
 283                    op1 = ...
 284                    op2 = ...
 285                  }
 286
 287 The "maybe" says that we only ask AbsBinds to make global constant methods
 288 if the dfun_theta is empty.
 289
 290
 291 For an instance declaration, say,
 292
 293         instance (C1 a, C2 b) => C (T a b) where
 294                 ...
 295
 296 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 297 function whose type is
 298
 299         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 300
 301 Notice that we pass it the superclass dictionaries at the instance type; this
 302 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 303 is the @dfun_theta@ below.
 304
 305 First comes the easy case of a non-local instance decl.
 306
 307 \begin{code}
 308 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
 309
 310 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
 311                       inst_decl_theta dfun_theta
 312                       dfun_id monobinds
 313                       locn uprags)
 314   | not (isLocallyDefined dfun_id)
 315   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 316
 317 {-
 318   -- I deleted this "optimisation" because when importing these
 319   -- instance decls the renamer would look for the dfun bindings and they weren't there.
 320   -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
 321   -- even though it's never used.
 322
 323         -- This case deals with CCallable etc, which don't need any bindings
 324   | isNoDictClass clas
 325   = returnNF_Tc (emptyLIE, EmptyBinds)
 326 -}
 327
 328   | otherwise
 329   =      -- Prime error recovery
 330     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 331     tcAddSrcLoc locn                                       $
 332
 333         -- Get the class signature
 334     let
 335         origin = InstanceDeclOrigin
 336         (class_tyvars,
 337          sc_theta, sc_sel_ids,
 338          op_sel_ids, defm_ids) = classBigSig clas
 339     in
 340
 341         -- Instantiate the instance decl with tc-style type variables
 342     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 343     mapNF_Tc (tcInstType tenv) inst_tys `thenNF_Tc` \ inst_tys' ->
 344     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 345     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 346
 347          -- Instantiate the super-class context with inst_tys
 348
 349     tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta           `thenNF_Tc` \ sc_theta' ->
 350
 351          -- Create dictionary Ids from the specified instance contexts.
 352     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 353     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 354     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 355     newDicts origin [(clas,inst_tys')]  `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 356
 357         -- Now process any INLINE or SPECIALIZE pragmas for the methods
 358         -- ...[NB May 97; all ignored except INLINE]
 359     tcPragmaSigs uprags               `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
 360
 361          -- Check that all the method bindings come from this class
 362     let
 363         check_from_this_class (bndr, loc)
 364           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 365           | otherwise                         = tcAddSrcLoc loc $
 366                                                 addErrTc (badMethodErr bndr clas)
 367         sel_names = map getOccName op_sel_ids
 368         bndrs = bagToList (collectMonoBinders monobinds)
 369     in
 370     mapNF_Tc check_from_this_class bndrs                `thenNF_Tc_`
 371
 372     tcExtendGlobalValEnv (catMaybes defm_ids) (
 373
 374                 -- Default-method Ids may be mentioned in synthesised RHSs
 375         mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds)
 376                        (op_sel_ids `zip` defm_ids)
 377     )                   `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 378
 379         -- Check the overloading constraints of the methods and superclasses
 380     mapNF_Tc zonkSigTyVar inst_tyvars'  `thenNF_Tc` \ zonked_inst_tyvars ->
 381
 382     let
 383         inst_tyvars_set = mkTyVarSet zonked_inst_tyvars
 384
 385         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 386
 387                  -- These insts are in scope; quite a few, eh?
 388         avail_insts = this_dict                 `plusLIE`
 389                       dfun_arg_dicts            `plusLIE`
 390                       sc_dicts                  `plusLIE`
 391                       unionManyBags meth_lies
 392     in
 393     tcAddErrCtxt superClassCtxt $
 394     tcAddErrCtxtM (sigThetaCtxt sc_dicts) $
 395
 396
 397                 -- Deal with the LIE arising from the method bindings
 398     tcSimplifyAndCheck (text "inst decl1a")
 399                  inst_tyvars_set                        -- Local tyvars
 400                  avail_insts
 401                  (unionManyBags insts_needed_s)         -- Need to get defns for all these
 402                                                  `thenTc` \ (const_lie1, op_binds) ->
 403
 404                 -- Deal with the super-class bindings
 405                 -- Ignore errors because they come from the *next* tcSimplify
 406     discardErrsTc (
 407         tcSimplifyAndCheck (text "inst decl1b")
 408                  inst_tyvars_set
 409                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 410                                         -- get bound by just selecting from this_dict!!
 411                  sc_dicts
 412     )                                            `thenTc` \ (const_lie2, sc_binds) ->
 413
 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     tcSimplifyAndCheck (text "inst decl1c")
 420                  inst_tyvars_set                -- Local tyvars
 421                  inst_decl_dicts                -- The instance dictionaries available
 422                  sc_dicts                       -- The superclass dicationaries reqd
 423                                         `thenTc_`
 424                                                 -- Ignore the result; we're only doing
 425                                                 -- this to make sure it can be done.
 426
 427         -- Create the result bindings
 428     let
 429         const_lie = const_lie1 `plusLIE` const_lie2
 430         lie_binds = op_binds `AndMonoBinds` sc_binds
 431
 432         dict_constr = classDataCon clas
 433
 434         con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
 435                               (map HsVar (sc_dict_ids ++ meth_ids))
 436                 -- We don't produce a binding for the dict_constr; instead we
 437                 -- rely on the simplifier to unfold this saturated application
 438
 439         dict_bind    = VarMonoBind this_dict_id con_app
 440         method_binds = andMonoBinds method_binds_s
 441
 442         main_bind
 443           = AbsBinds
 444                  zonked_inst_tyvars
 445                  dfun_arg_dicts_ids
 446                  [(inst_tyvars', RealId dfun_id, this_dict_id)]
 447                  (lie_binds     `AndMonoBinds`
 448                   method_binds  `AndMonoBinds`
 449                   dict_bind)
 450     in
 451     returnTc (const_lie `plusLIE` spec_lie,
 452               main_bind `AndMonoBinds` spec_binds)
 453 \end{code}
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458 \subsection{Processing each method}
 459 %*                                                                      *
 460 %************************************************************************
 461
 462 \begin{code}
 463 tcInstMethodBind
 464         :: Class
 465         -> [TcType s]                                   -- Instance types
 466         -> [TcTyVar s]                                  -- and their free (sig) tyvars
 467         -> RenamedMonoBinds                             -- Method binding
 468         -> (Id, Maybe Id)                               -- Selector id and default-method id
 469         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 470
 471 tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id)
 472   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 473     tcGetUnique                 `thenNF_Tc` \ uniq ->
 474     let
 475         meth_occ          = getOccName sel_id
 476         default_meth_name = mkLocalName uniq meth_occ loc
 477         maybe_meth_bind   = find meth_occ meth_binds
 478         the_meth_bind     = case maybe_meth_bind of
 479                                   Just stuff -> stuff
 480                                   Nothing    -> mk_default_bind default_meth_name loc
 481     in
 482
 483         -- Warn if no method binding, only if -fwarn-missing-methods
 484
 485     warnTc (opt_WarnMissingMethods &&
 486             not (maybeToBool maybe_meth_bind) &&
 487             not (maybeToBool maybe_dm_id))
 488         (omittedMethodWarn sel_id clas)         `thenNF_Tc_`
 489
 490         -- Typecheck the method binding
 491     tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind
 492   where
 493     origin = InstanceDeclOrigin         -- Poor
 494
 495     find occ EmptyMonoBinds       = Nothing
 496     find occ (AndMonoBinds b1 b2) = find occ b1 `seqMaybe` find occ b2
 497
 498     find occ b@(FunMonoBind op_name _ _ _)          | nameOccName op_name == occ = Just b
 499                                                     | otherwise           = Nothing
 500     find occ b@(PatMonoBind (VarPatIn op_name) _ _) | nameOccName op_name == occ = Just b
 501                                                     | otherwise           = Nothing
 502     find occ other = panic "Urk! Bad instance method binding"
 503
 504
 505     mk_default_bind local_meth_name loc
 506       = PatMonoBind (VarPatIn local_meth_name)
 507                     (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
 508                     loc
 509
 510     default_expr loc
 511       = case maybe_dm_id of
 512           Just dm_id -> HsVar (getName dm_id)   -- There's a default method
 513           Nothing    -> error_expr loc          -- No default method
 514
 515     error_expr loc
 516       = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
 517                      (HsLit (HsString (_PK_ (error_msg loc))))
 518
 519     error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 520
 521 \end{code}
 522
 523
 524
 525 %************************************************************************
 526 %*                                                                      *
 527 \subsection{Type-checking specialise instance pragmas}
 528 %*                                                                      *
 529 %************************************************************************
 530
 531 \begin{code}
 532 {- LATER
 533 tcSpecInstSigs :: E -> CE -> TCE
 534                -> Bag InstInfo          -- inst decls seen (declared and derived)
 535                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 536                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 537
 538 tcSpecInstSigs e ce tce inst_infos []
 539   = returnTc emptyBag
 540
 541 tcSpecInstSigs e ce tce inst_infos sigs
 542   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 543     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 544     returnTc spec_inst_infos
 545   where
 546     tc_inst_spec_sigs inst_mapper []
 547       = returnNF_Tc emptyBag
 548     tc_inst_spec_sigs inst_mapper (sig:sigs)
 549       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 550         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 551         returnNF_Tc (info_sig `unionBags` info_sigs)
 552
 553 tcSpecInstSig :: E -> CE -> TCE
 554               -> Bag InstInfo
 555               -> InstanceMapper
 556               -> RenamedSpecInstSig
 557               -> NF_TcM (Bag InstInfo)
 558
 559 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 560   = recoverTc emptyBag                  (
 561     tcAddSrcLoc src_loc                 (
 562     let
 563         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 564
 565         -- Make some new type variables, named as in the specialised instance type
 566         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 567         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 568     in
 569     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 570                                 `thenTc` \ inst_ty ->
 571     let
 572         maybe_tycon = case splitAlgTyConApp_maybe inst_ty of
 573                          Just (tc,_,_) -> Just tc
 574                          Nothing       -> Nothing
 575
 576         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 577     in
 578         -- Check that we have a local instance declaration to specialise
 579     checkMaybeTc maybe_unspec_inst
 580             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 581
 582         -- Create tvs to substitute for tmpls while simplifying the context
 583     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 584     let
 585         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 586                        _ _ binds _ uprag) = maybe_unspec_inst
 587
 588         subst = case matchTy unspec_inst_ty inst_ty of
 589                      Just subst -> subst
 590                      Nothing    -> panic "tcSpecInstSig:matchTy"
 591
 592         subst_theta    = instantiateThetaTy subst unspec_theta
 593         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 594
 595         mk_spec_origin clas ty
 596           = InstanceSpecOrigin inst_mapper clas ty src_loc
 597         -- I'm VERY SUSPICIOUS ABOUT THIS
 598         -- the inst-mapper is in a knot at this point so it's no good
 599         -- looking at it in tcSimplify...
 600     in
 601     tcSimplifyThetas mk_spec_origin subst_tv_theta
 602                                 `thenTc` \ simpl_tv_theta ->
 603     let
 604         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 605
 606         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 607         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 608     in
 609     mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag
 610                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 611
 612     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 613     (if sw_chkr SpecialiseTrace then
 614         pprTrace "Specialised Instance: "
 615         (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
 616                           if null simpl_theta then empty else ptext SLIT("=>"),
 617                           ppr clas,
 618                           pprParendGenType inst_ty],
 619                    hsep [ptext SLIT("        derived from:"),
 620                           if null unspec_theta then empty else ppr unspec_theta,
 621                           if null unspec_theta then empty else ptext SLIT("=>"),
 622                           ppr clas,
 623                           pprParendGenType unspec_inst_ty]])
 624     else id) (
 625
 626     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 627                                 dfun_theta dfun_id
 628                                 binds src_loc uprag))
 629     )))
 630
 631
 632 lookup_unspec_inst clas maybe_tycon inst_infos
 633   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 634         []       -> Nothing
 635         (info:_) -> Just info
 636   where
 637     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 638       = from_here && clas == inst_clas &&
 639         match_ty inst_ty && is_plain_instance inst_ty
 640
 641     match_inst_ty = case maybe_tycon of
 642                       Just tycon -> match_tycon tycon
 643                       Nothing    -> match_fun
 644
 645     match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of
 646           Just (inst_tc,_,_) -> tycon == inst_tc
 647           Nothing            -> False
 648
 649     match_fun inst_ty = isFunType inst_ty
 650
 651
 652 is_plain_instance inst_ty
 653   = case (splitAlgTyConApp_maybe inst_ty) of
 654       Just (_,tys,_) -> all isTyVarTemplateTy tys
 655       Nothing        -> case maybeUnpackFunTy inst_ty of
 656                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 657                           Nothing         -> error "TcInstDecls:is_plain_instance"
 658 -}
 659 \end{code}
 660
 661
 662 Checking for a decent instance type
 663 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 664 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 665 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 666
 667 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 668 flag is on, or (2)~the instance is imported (they must have been
 669 compiled elsewhere). In these cases, we let them go through anyway.
 670
 671 We can also have instances for functions: @instance Foo (a -> b) ...@.
 672
 673 \begin{code}
 674 scrutiniseInstanceType clas inst_taus
 675   |     -- CCALL CHECK (a).... urgh!
 676         -- To verify that a user declaration of a CCallable/CReturnable
 677         -- instance is OK, we must be able to see the constructor(s)
 678         -- of the instance type (see next guard.)
 679         --
 680         -- We flag this separately to give a more precise error msg.
 681         --
 682     (uniqueOf clas == cCallableClassKey   && not constructors_visible) ||
 683     (uniqueOf clas == cReturnableClassKey && not constructors_visible)
 684   = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
 685
 686   |     -- CCALL CHECK (b)
 687         -- A user declaration of a CCallable/CReturnable instance
 688         -- must be for a "boxed primitive" type.
 689     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
 690     (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
 691   = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)
 692
 693         -- DERIVING CHECK
 694         -- It is obviously illegal to have an explicit instance
 695         -- for something that we are also planning to `derive'
 696   | clas `elem` (tyConDerivings inst_tycon)
 697   = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
 698            -- Kind check will have ensured inst_taus is of length 1
 699
 700         -- ALL TYPE VARIABLES => bad
 701   | all isTyVarTy inst_taus
 702   = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables"))
 703
 704         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 705   |  not opt_GlasgowExts
 706   && not (length inst_taus == 1 &&
 707           maybeToBool tyconapp_maybe &&
 708           not (isSynTyCon inst_tycon) &&
 709           all isTyVarTy arg_tys &&
 710           length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
 711                  -- This last condition checks that all the type variables are distinct
 712      )
 713   = failWithTc (instTypeErr clas inst_taus
 714                         (text "the instance type must be of form (T a b c)" $$
 715                          text "where T is not a synonym, and a,b,c are distinct type variables")
 716     )
 717
 718   | otherwise
 719   = returnTc ()
 720
 721   where
 722     tyconapp_maybe             = splitTyConApp_maybe first_inst_tau
 723     Just (inst_tycon, arg_tys) = tyconapp_maybe
 724     (first_inst_tau : _)       = inst_taus
 725
 726     constructors_visible      =
 727         case splitAlgTyConApp_maybe first_inst_tau of
 728            Just (_,_,[])   -> False
 729            everything_else -> True
 730
 731 -- These conditions come directly from what the DsCCall is capable of.
 732 -- Totally grotesque.  Green card should solve this.
 733
 734 ccallable_type   ty = isUnpointedType ty ||                             -- Allow CCallable Int# etc
 735                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 736                       ty == stringTy ||
 737                       byte_arr_thing
 738   where
 739     byte_arr_thing = case splitAlgTyConApp_maybe ty of
 740                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 741                                 length data_con_arg_tys == 2 &&
 742                                 maybeToBool maybe_arg2_tycon &&
 743                                 (arg2_tycon == byteArrayPrimTyCon ||
 744                                  arg2_tycon == mutableByteArrayPrimTyCon)
 745                              where
 746                                 data_con_arg_tys = dataConArgTys data_con ty_args
 747                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 748                                 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
 749                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 750
 751                         other -> False
 752
 753 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 754                         -- Or, a data type with a single nullary constructor
 755                       case (splitAlgTyConApp_maybe ty) of
 756                         Just (tycon, tys_applied, [data_con])
 757                                 -> isNullaryDataCon data_con
 758                         other -> False
 759 \end{code}
 760
 761 \begin{code}
 762
 763 instTypeErr clas tys msg
 764   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 765          nest 4 (parens msg)
 766     ]
 767
 768 instBndrErr bndr clas
 769   = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)]
 770
 771 derivingWhenInstanceExistsErr clas tycon
 772   = hang (hsep [ptext SLIT("Deriving class"),
 773                        quotes (ppr clas),
 774                        ptext SLIT("type"), quotes (ppr tycon)])
 775          4 (ptext SLIT("when an explicit instance exists"))
 776
 777 nonBoxedPrimCCallErr clas inst_ty
 778   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 779          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 780                         ppr inst_ty])
 781
 782 omittedMethodWarn sel_id clas
 783   = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
 784          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 785
 786 {-
 787   Declaring CCallable & CReturnable instances in a module different
 788   from where the type was defined. Caused by importing data type
 789   abstractly (either programmatically or by the renamer being over-eager
 790   in its pruning.)
 791 -}
 792 invisibleDataConPrimCCallErr clas inst_ty
 793   = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
 794                 ptext SLIT("not visible when checking"),
 795                 quotes (ppr clas), ptext SLIT("instance")])
 796         4 (hsep [text "(Try either importing", ppr inst_ty,
 797                  text "non-abstractly or compile using -fno-prune-tydecls ..)"])
 798
 799 instMethodNotInClassErr occ clas
 800   = hang (ptext SLIT("Instance mentions a method not in the class"))
 801          4 (hsep [ptext SLIT("class")  <+> quotes (ppr clas),
 802                   ptext SLIT("method") <+> quotes (ppr occ)])
 803
 804 patMonoBindsCtxt pbind
 805   = hang (ptext SLIT("In a pattern binding:"))
 806          4 (ppr pbind)
 807
 808 methodSigCtxt name ty
 809   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 810                 quotes (ppr name), ptext SLIT("to its signature :") ])
 811          4 (ppr ty)
 812
 813 superClassCtxt = ptext SLIT("From the superclasses of the instance declaration")
 814 \end{code}