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_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_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) EmptyBinds)
 508                     loc
 509
 510     default_expr = case maybe_dm_id of
 511                         Just dm_id -> HsVar (getName dm_id)     -- There's a default method
 512                         Nothing    -> error_expr                -- No default method
 513
 514     error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
 515                               (HsLit (HsString (_PK_ error_msg)))
 516
 517     error_msg = show (hcat [ppr (getSrcLoc sel_id), text "|",
 518                             ppr sel_id
 519                 ])
 520 \end{code}
 521
 522
 523
 524 %************************************************************************
 525 %*                                                                      *
 526 \subsection{Type-checking specialise instance pragmas}
 527 %*                                                                      *
 528 %************************************************************************
 529
 530 \begin{code}
 531 {- LATER
 532 tcSpecInstSigs :: E -> CE -> TCE
 533                -> Bag InstInfo          -- inst decls seen (declared and derived)
 534                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 535                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 536
 537 tcSpecInstSigs e ce tce inst_infos []
 538   = returnTc emptyBag
 539
 540 tcSpecInstSigs e ce tce inst_infos sigs
 541   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 542     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 543     returnTc spec_inst_infos
 544   where
 545     tc_inst_spec_sigs inst_mapper []
 546       = returnNF_Tc emptyBag
 547     tc_inst_spec_sigs inst_mapper (sig:sigs)
 548       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 549         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 550         returnNF_Tc (info_sig `unionBags` info_sigs)
 551
 552 tcSpecInstSig :: E -> CE -> TCE
 553               -> Bag InstInfo
 554               -> InstanceMapper
 555               -> RenamedSpecInstSig
 556               -> NF_TcM (Bag InstInfo)
 557
 558 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 559   = recoverTc emptyBag                  (
 560     tcAddSrcLoc src_loc                 (
 561     let
 562         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 563
 564         -- Make some new type variables, named as in the specialised instance type
 565         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 566         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 567     in
 568     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 569                                 `thenTc` \ inst_ty ->
 570     let
 571         maybe_tycon = case splitAlgTyConApp_maybe inst_ty of
 572                          Just (tc,_,_) -> Just tc
 573                          Nothing       -> Nothing
 574
 575         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 576     in
 577         -- Check that we have a local instance declaration to specialise
 578     checkMaybeTc maybe_unspec_inst
 579             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 580
 581         -- Create tvs to substitute for tmpls while simplifying the context
 582     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 583     let
 584         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 585                        _ _ binds _ uprag) = maybe_unspec_inst
 586
 587         subst = case matchTy unspec_inst_ty inst_ty of
 588                      Just subst -> subst
 589                      Nothing    -> panic "tcSpecInstSig:matchTy"
 590
 591         subst_theta    = instantiateThetaTy subst unspec_theta
 592         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 593
 594         mk_spec_origin clas ty
 595           = InstanceSpecOrigin inst_mapper clas ty src_loc
 596         -- I'm VERY SUSPICIOUS ABOUT THIS
 597         -- the inst-mapper is in a knot at this point so it's no good
 598         -- looking at it in tcSimplify...
 599     in
 600     tcSimplifyThetas mk_spec_origin subst_tv_theta
 601                                 `thenTc` \ simpl_tv_theta ->
 602     let
 603         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 604
 605         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 606         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 607     in
 608     mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag
 609                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 610
 611     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 612     (if sw_chkr SpecialiseTrace then
 613         pprTrace "Specialised Instance: "
 614         (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
 615                           if null simpl_theta then empty else ptext SLIT("=>"),
 616                           ppr clas,
 617                           pprParendGenType inst_ty],
 618                    hsep [ptext SLIT("        derived from:"),
 619                           if null unspec_theta then empty else ppr unspec_theta,
 620                           if null unspec_theta then empty else ptext SLIT("=>"),
 621                           ppr clas,
 622                           pprParendGenType unspec_inst_ty]])
 623     else id) (
 624
 625     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 626                                 dfun_theta dfun_id
 627                                 binds src_loc uprag))
 628     )))
 629
 630
 631 lookup_unspec_inst clas maybe_tycon inst_infos
 632   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 633         []       -> Nothing
 634         (info:_) -> Just info
 635   where
 636     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 637       = from_here && clas == inst_clas &&
 638         match_ty inst_ty && is_plain_instance inst_ty
 639
 640     match_inst_ty = case maybe_tycon of
 641                       Just tycon -> match_tycon tycon
 642                       Nothing    -> match_fun
 643
 644     match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of
 645           Just (inst_tc,_,_) -> tycon == inst_tc
 646           Nothing            -> False
 647
 648     match_fun inst_ty = isFunType inst_ty
 649
 650
 651 is_plain_instance inst_ty
 652   = case (splitAlgTyConApp_maybe inst_ty) of
 653       Just (_,tys,_) -> all isTyVarTemplateTy tys
 654       Nothing        -> case maybeUnpackFunTy inst_ty of
 655                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 656                           Nothing         -> error "TcInstDecls:is_plain_instance"
 657 -}
 658 \end{code}
 659
 660
 661 Checking for a decent instance type
 662 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 663 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 664 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 665
 666 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 667 flag is on, or (2)~the instance is imported (they must have been
 668 compiled elsewhere). In these cases, we let them go through anyway.
 669
 670 We can also have instances for functions: @instance Foo (a -> b) ...@.
 671
 672 \begin{code}
 673 scrutiniseInstanceType clas inst_taus
 674   |     -- CCALL CHECK (a).... urgh!
 675         -- To verify that a user declaration of a CCallable/CReturnable
 676         -- instance is OK, we must be able to see the constructor(s)
 677         -- of the instance type (see next guard.)
 678         --
 679         -- We flag this separately to give a more precise error msg.
 680         --
 681     (uniqueOf clas == cCallableClassKey   && not constructors_visible) ||
 682     (uniqueOf clas == cReturnableClassKey && not constructors_visible)
 683   = failWithTc (invisibleDataConPrimCCallErr clas first_inst_tau)
 684
 685   |     -- CCALL CHECK (b)
 686         -- A user declaration of a CCallable/CReturnable instance
 687         -- must be for a "boxed primitive" type.
 688     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
 689     (uniqueOf clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
 690   = failWithTc (nonBoxedPrimCCallErr clas first_inst_tau)
 691
 692         -- DERIVING CHECK
 693         -- It is obviously illegal to have an explicit instance
 694         -- for something that we are also planning to `derive'
 695   | clas `elem` (tyConDerivings inst_tycon)
 696   = failWithTc (derivingWhenInstanceExistsErr clas first_inst_tau)
 697            -- Kind check will have ensured inst_taus is of length 1
 698
 699         -- ALL TYPE VARIABLES => bad
 700   | all isTyVarTy inst_taus
 701   = failWithTc (instTypeErr clas inst_taus (text "all the instance types are type variables"))
 702
 703         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 704   |  not opt_GlasgowExts
 705   && not (length inst_taus == 1 &&
 706           maybeToBool tyconapp_maybe &&
 707           not (isSynTyCon inst_tycon) &&
 708           all isTyVarTy arg_tys &&
 709           length (tyVarSetToList (tyVarsOfTypes arg_tys)) == length arg_tys
 710                  -- This last condition checks that all the type variables are distinct
 711      )
 712   = failWithTc (instTypeErr clas inst_taus
 713                         (text "the instance type must be of form (T a b c)" $$
 714                          text "where T is not a synonym, and a,b,c are distinct type variables")
 715     )
 716
 717   | otherwise
 718   = returnTc ()
 719
 720   where
 721     tyconapp_maybe             = splitTyConApp_maybe first_inst_tau
 722     Just (inst_tycon, arg_tys) = tyconapp_maybe
 723     (first_inst_tau : _)       = inst_taus
 724
 725     constructors_visible      =
 726         case splitAlgTyConApp_maybe first_inst_tau of
 727            Just (_,_,[])   -> False
 728            everything_else -> True
 729
 730 -- These conditions come directly from what the DsCCall is capable of.
 731 -- Totally grotesque.  Green card should solve this.
 732
 733 ccallable_type   ty = isUnpointedType ty ||                             -- Allow CCallable Int# etc
 734                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 735                       ty == stringTy ||
 736                       byte_arr_thing
 737   where
 738     byte_arr_thing = case splitAlgTyConApp_maybe ty of
 739                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 740                                 length data_con_arg_tys == 2 &&
 741                                 maybeToBool maybe_arg2_tycon &&
 742                                 (arg2_tycon == byteArrayPrimTyCon ||
 743                                  arg2_tycon == mutableByteArrayPrimTyCon)
 744                              where
 745                                 data_con_arg_tys = dataConArgTys data_con ty_args
 746                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 747                                 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
 748                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 749
 750                         other -> False
 751
 752 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 753                         -- Or, a data type with a single nullary constructor
 754                       case (splitAlgTyConApp_maybe ty) of
 755                         Just (tycon, tys_applied, [data_con])
 756                                 -> isNullaryDataCon data_con
 757                         other -> False
 758 \end{code}
 759
 760 \begin{code}
 761
 762 instTypeErr clas tys msg
 763   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 764          nest 4 (parens msg)
 765     ]
 766
 767 instBndrErr bndr clas
 768   = hsep [ptext SLIT("Class"), quotes (ppr clas), ptext SLIT("does not have a method"), quotes (ppr bndr)]
 769
 770 derivingWhenInstanceExistsErr clas tycon
 771   = hang (hsep [ptext SLIT("Deriving class"),
 772                        quotes (ppr clas),
 773                        ptext SLIT("type"), quotes (ppr tycon)])
 774          4 (ptext SLIT("when an explicit instance exists"))
 775
 776 nonBoxedPrimCCallErr clas inst_ty
 777   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 778          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 779                         ppr inst_ty])
 780
 781 omittedMethodWarn sel_id clas
 782   = sep [ptext SLIT("Warning: no explicit method nor default method for") <+> quotes (ppr sel_id),
 783          ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
 784
 785 {-
 786   Declaring CCallable & CReturnable instances in a module different
 787   from where the type was defined. Caused by importing data type
 788   abstractly (either programmatically or by the renamer being over-eager
 789   in its pruning.)
 790 -}
 791 invisibleDataConPrimCCallErr clas inst_ty
 792   = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
 793                 ptext SLIT("not visible when checking"),
 794                 quotes (ppr clas), ptext SLIT("instance")])
 795         4 (hsep [text "(Try either importing", ppr inst_ty,
 796                  text "non-abstractly or compile using -fno-prune-tydecls ..)"])
 797
 798 instMethodNotInClassErr occ clas
 799   = hang (ptext SLIT("Instance mentions a method not in the class"))
 800          4 (hsep [ptext SLIT("class")  <+> quotes (ppr clas),
 801                   ptext SLIT("method") <+> quotes (ppr occ)])
 802
 803 patMonoBindsCtxt pbind
 804   = hang (ptext SLIT("In a pattern binding:"))
 805          4 (ppr pbind)
 806
 807 methodSigCtxt name ty
 808   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 809                 quotes (ppr name), ptext SLIT("to its signature :") ])
 810          4 (ppr ty)
 811
 812 superClassCtxt = ptext SLIT("From the superclasses of the instance declaration")
 813 \end{code}