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