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