ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcInstDcls (
  10         tcInstDecls1,
  11         tcInstDecls2,
  12         tcMethodBind
  13     ) where
  14
  15
  16 IMP_Ubiq()
  17
  18 import HsSyn            ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
  19                           FixityDecl, IfaceSig, Sig(..),
  20                           SpecInstSig(..), HsBinds(..),
  21                           MonoBinds(..), GRHSsAndBinds(..), GRHS(..), Match,
  22                           InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  23                           Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity,
  24                           HsType(..), HsTyVar,
  25                           SYN_IE(RecFlag), recursive, nonRecursive, collectMonoBinders,
  26                           andMonoBinds
  27                         )
  28 import RnHsSyn          ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
  29                           SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl), SYN_IE(RenamedHsExpr),
  30                           SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
  31                         )
  32 import TcHsSyn          ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcHsBinds),
  33                           SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
  34                           mkHsTyLam, mkHsTyApp,
  35                           mkHsDictLam, mkHsDictApp )
  36
  37 import TcBinds          ( tcBindWithSigs, TcSigInfo(..) )
  38 import TcMonad
  39 import RnMonad          ( SYN_IE(RnNameSupply) )
  40 import Inst             ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
  41                           instToId, newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
  42 import TcBinds          ( tcPragmaSigs, checkSigTyVars )
  43 import PragmaInfo       ( PragmaInfo(..) )
  44 import TcDeriv          ( tcDeriving )
  45 import TcEnv            ( tcLookupClass, newLocalId, tcExtendGlobalTyVars, tcGetGlobalTyVars )
  46 import SpecEnv          ( SpecEnv )
  47 import TcGRHSs          ( tcGRHSsAndBinds )
  48 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  49 import TcKind           ( TcKind, unifyKind )
  50 import TcMatches        ( tcMatchesFun )
  51 import TcMonoType       ( tcTyVarScope, tcContext, tcHsTypeKind )
  52 import TcSimplify       ( tcSimplifyAndCheck )
  53 import TcType           ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
  54                           tcInstSigTyVars, tcInstType, tcInstSigTcType,
  55                           tcInstTheta, tcInstTcType, tcInstSigType
  56                         )
  57 import Unify            ( unifyTauTy, unifyTauTyLists )
  58
  59
  60 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  61                           concatBag, foldBag, bagToList, listToBag,
  62                           Bag )
  63 import CmdLineOpts      ( opt_GlasgowExts, opt_CompilingGhcInternals,
  64                           opt_OmitDefaultInstanceMethods,
  65                           opt_SpecialiseOverloaded
  66                         )
  67 import Class            ( GenClass, GenClassOp,
  68                           classBigSig, classOps, classOpLocalType,
  69                           classDefaultMethodId, SYN_IE(Class)
  70                           )
  71 import Id               ( GenId, idType, isDefaultMethodId_maybe,
  72                           isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
  73 import ListSetOps       ( minusList )
  74 import Maybes           ( maybeToBool, expectJust, seqMaybe )
  75 import Name             ( nameOccName, getOccString, occNameString, moduleString, getOccName,
  76                           isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
  77                           NamedThing(..)
  78                         )
  79 import PrelVals         ( nO_EXPLICIT_METHOD_ERROR_ID )
  80 import PprType          ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
  81                           pprParendGenType
  82                         )
  83 import PprStyle
  84 import Outputable
  85 import SrcLoc           ( SrcLoc, noSrcLoc )
  86 import Pretty
  87 import TyCon            ( isSynTyCon, derivedFor )
  88 import Type             ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
  89                           splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
  90                           getTyCon_maybe, maybeAppTyCon, SYN_IE(Type),
  91                           maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
  92                         )
  93 import TyVar            ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
  94                           mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) )
  95 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  96 import TysWiredIn       ( stringTy )
  97 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey )
  98 import UniqFM           ( Uniquable(..) )
  99 import Util             ( zipEqual, panic, pprPanic, pprTrace
 100 #if __GLASGOW_HASKELL__ < 202
 101                           , trace
 102 #endif
 103                         )
 104 \end{code}
 105
 106 Typechecking instance declarations is done in two passes. The first
 107 pass, made by @tcInstDecls1@, collects information to be used in the
 108 second pass.
 109
 110 This pre-processed info includes the as-yet-unprocessed bindings
 111 inside the instance declaration.  These are type-checked in the second
 112 pass, when the class-instance envs and GVE contain all the info from
 113 all the instance and value decls.  Indeed that's the reason we need
 114 two passes over the instance decls.
 115
 116
 117 Here is the overall algorithm.
 118 Assume that we have an instance declaration
 119
 120     instance c => k (t tvs) where b
 121
 122 \begin{enumerate}
 123 \item
 124 $LIE_c$ is the LIE for the context of class $c$
 125 \item
 126 $betas_bar$ is the free variables in the class method type, excluding the
 127    class variable
 128 \item
 129 $LIE_cop$ is the LIE constraining a particular class method
 130 \item
 131 $tau_cop$ is the tau type of a class method
 132 \item
 133 $LIE_i$ is the LIE for the context of instance $i$
 134 \item
 135 $X$ is the instance constructor tycon
 136 \item
 137 $gammas_bar$ is the set of type variables of the instance
 138 \item
 139 $LIE_iop$ is the LIE for a particular class method instance
 140 \item
 141 $tau_iop$ is the tau type for this instance of a class method
 142 \item
 143 $alpha$ is the class variable
 144 \item
 145 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 146 \item
 147 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 148 \end{enumerate}
 149
 150 ToDo: Update the list above with names actually in the code.
 151
 152 \begin{enumerate}
 153 \item
 154 First, make the LIEs for the class and instance contexts, which means
 155 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 156 and make LIElistI and LIEI.
 157 \item
 158 Then process each method in turn.
 159 \item
 160 order the instance methods according to the ordering of the class methods
 161 \item
 162 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 163 \item
 164 Create final dictionary function from bindings generated already
 165 \begin{pseudocode}
 166 df = lambda inst_tyvars
 167        lambda LIEI
 168          let Bop1
 169              Bop2
 170              ...
 171              Bopn
 172          and dbinds_super
 173               in <op1,op2,...,opn,sd1,...,sdm>
 174 \end{pseudocode}
 175 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 176 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 177 \end{enumerate}
 178
 179 \begin{code}
 180 tcInstDecls1 :: [RenamedHsDecl]
 181              -> Module                  -- module name for deriving
 182              -> RnNameSupply                    -- for renaming derivings
 183              -> TcM s (Bag InstInfo,
 184                        RenamedHsBinds,
 185                        PprStyle -> Doc)
 186
 187 tcInstDecls1 decls mod_name rn_name_supply
 188   =     -- Do the ordinary instance declarations
 189     mapNF_Tc (tcInstDecl1 mod_name)
 190              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 191     let
 192         decl_inst_info = unionManyBags inst_info_bags
 193     in
 194         -- Handle "derived" instances; note that we only do derivings
 195         -- for things in this module; we ignore deriving decls from
 196         -- interfaces! We pass fixities, because they may be used
 197         -- in deriving Read and Show.
 198     tcDeriving mod_name rn_name_supply decl_inst_info
 199                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 200
 201     let
 202         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 203     in
 204     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 205
 206
 207 tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 208
 209 tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 210   =     -- Prime error recovery, set source location
 211     recoverNF_Tc (returnNF_Tc emptyBag) $
 212     tcAddSrcLoc src_loc                 $
 213
 214         -- Look things up
 215     tcLookupClass class_name            `thenTc` \ (clas_kind, clas) ->
 216
 217         -- Typecheck the context and instance type
 218     tcTyVarScope tyvar_names (\ tyvars ->
 219         tcContext context               `thenTc` \ theta ->
 220         tcHsTypeKind inst_ty            `thenTc` \ (tau_kind, tau) ->
 221         unifyKind clas_kind tau_kind    `thenTc_`
 222         returnTc (tyvars, theta, tau)
 223     )                                   `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 224
 225         -- Check for respectable instance type
 226     scrutiniseInstanceType dfun_name clas inst_tau
 227                                         `thenTc` \ (inst_tycon,arg_tys) ->
 228
 229         -- Make the dfun id and constant-method ids
 230     mkInstanceRelatedIds dfun_name
 231                          clas inst_tyvars inst_tau inst_theta
 232                                         `thenNF_Tc` \ (dfun_id, dfun_theta) ->
 233
 234     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
 235                                 dfun_theta dfun_id
 236                                 binds src_loc uprags))
 237   where
 238     (tyvar_names, context, dict_ty) = case poly_ty of
 239                                         HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
 240                                         other                      -> ([],  [],  poly_ty)
 241     (class_name, inst_ty) = case dict_ty of
 242                                 MonoDictTy cls ty -> (cls,ty)
 243                                 other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
 244 \end{code}
 245
 246
 247 %************************************************************************
 248 %*                                                                      *
 249 \subsection{Type-checking instance declarations, pass 2}
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 \begin{code}
 254 tcInstDecls2 :: Bag InstInfo
 255              -> NF_TcM s (LIE s, TcHsBinds s)
 256
 257 tcInstDecls2 inst_decls
 258   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
 259   where
 260     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 261                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 262                       returnNF_Tc (lie1 `plusLIE` lie2,
 263                                    binds1 `ThenBinds` binds2)
 264 \end{code}
 265
 266
 267 ======= New documentation starts here (Sept 92)  ==============
 268
 269 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 270 the dictionary function for this instance declaration.  For example
 271 \begin{verbatim}
 272         instance Foo a => Foo [a] where
 273                 op1 x = ...
 274                 op2 y = ...
 275 \end{verbatim}
 276 might generate something like
 277 \begin{verbatim}
 278         dfun.Foo.List dFoo_a = let op1 x = ...
 279                                    op2 y = ...
 280                                in
 281                                    Dict [op1, op2]
 282 \end{verbatim}
 283
 284 HOWEVER, if the instance decl has no context, then it returns a
 285 bigger @HsBinds@ with declarations for each method.  For example
 286 \begin{verbatim}
 287         instance Foo [a] where
 288                 op1 x = ...
 289                 op2 y = ...
 290 \end{verbatim}
 291 might produce
 292 \begin{verbatim}
 293         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 294         const.Foo.op1.List a x = ...
 295         const.Foo.op2.List a y = ...
 296 \end{verbatim}
 297 This group may be mutually recursive, because (for example) there may
 298 be no method supplied for op2 in which case we'll get
 299 \begin{verbatim}
 300         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 301 \end{verbatim}
 302 that is, the default method applied to the dictionary at this type.
 303
 304 What we actually produce in either case is:
 305
 306         AbsBinds [a] [dfun_theta_dicts]
 307                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 308                  { d = (sd1,sd2, ..., op1, op2, ...)
 309                    op1 = ...
 310                    op2 = ...
 311                  }
 312
 313 The "maybe" says that we only ask AbsBinds to make global constant methods
 314 if the dfun_theta is empty.
 315
 316
 317 For an instance declaration, say,
 318
 319         instance (C1 a, C2 b) => C (T a b) where
 320                 ...
 321
 322 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 323 function whose type is
 324
 325         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 326
 327 Notice that we pass it the superclass dictionaries at the instance type; this
 328 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 329 is the @dfun_theta@ below.
 330
 331 First comes the easy case of a non-local instance decl.
 332
 333 \begin{code}
 334 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcHsBinds s)
 335
 336 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 337                       inst_decl_theta dfun_theta
 338                       dfun_id monobinds
 339                       locn uprags)
 340   | not (isLocallyDefined dfun_id)
 341   = returnNF_Tc (emptyLIE, EmptyBinds)
 342
 343 {-
 344   -- I deleted this "optimisation" because when importing these
 345   -- instance decls the renamer would look for the dfun bindings and they weren't there.
 346   -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
 347   -- even though it's never used.
 348
 349         -- This case deals with CCallable etc, which don't need any bindings
 350   | isNoDictClass clas
 351   = returnNF_Tc (emptyLIE, EmptyBinds)
 352 -}
 353
 354   | otherwise
 355   =      -- Prime error recovery
 356     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds))   $
 357     tcAddSrcLoc locn                                    $
 358
 359         -- Get the class signature
 360     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 361     let
 362         origin = InstanceDeclOrigin
 363         (class_tyvar,
 364          super_classes, sc_sel_ids,
 365          class_ops, op_sel_ids, defm_ids) = classBigSig clas
 366     in
 367     tcInstType tenv inst_ty             `thenNF_Tc` \ inst_ty' ->
 368     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 369     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 370     let
 371         sc_theta'        = super_classes `zip` repeat inst_ty'
 372     in
 373          -- Create dictionary Ids from the specified instance contexts.
 374     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 375     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 376     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 377     newDicts origin [(clas,inst_ty')]   `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 378
 379          -- Check the method bindings
 380     let
 381         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 382         check_from_this_class (bndr, loc)
 383           | nameOccName bndr `elem` sel_names = returnTc ()
 384           | otherwise                         = recoverTc (returnTc ()) $
 385                                                 tcAddSrcLoc loc $
 386                                                 failTc (instBndrErr bndr clas)
 387         sel_names = map getOccName op_sel_ids
 388     in
 389     mapTc check_from_this_class (bagToList (collectMonoBinders monobinds))      `thenTc_`
 390     tcExtendGlobalTyVars inst_tyvars_set' (
 391         mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' monobinds)
 392                        (op_sel_ids `zip` [0..])
 393     )                                   `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 394
 395         -- Check the overloading constraints of the methods and superclasses
 396     let
 397         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 398         avail_insts      -- These insts are in scope; quite a few, eh?
 399           = this_dict `plusLIE` dfun_arg_dicts `plusLIE`  unionManyBags meth_lies
 400     in
 401     tcAddErrCtxt (bindSigCtxt meth_ids) (
 402         tcSimplifyAndCheck
 403                  inst_tyvars_set'                       -- Local tyvars
 404                  avail_insts
 405                  (sc_dicts `unionBags`
 406                   unionManyBags insts_needed_s)         -- Need to get defns for all these
 407     )                                    `thenTc` \ (const_lie, super_binds) ->
 408
 409         -- Check that we *could* construct the superclass dictionaries,
 410         -- even though we are *actually* going to pass the superclass dicts in;
 411         -- the check ensures that the caller will never have a problem building
 412         -- them.
 413     tcAddErrCtxt superClassSigCtxt (
 414         tcSimplifyAndCheck
 415                  inst_tyvars_set'               -- Local tyvars
 416                  inst_decl_dicts                -- The instance dictionaries available
 417                  sc_dicts                       -- The superclass dicationaries reqd
 418     )                                   `thenTc_`
 419                                                 -- Ignore the result; we're only doing
 420                                                 -- this to make sure it can be done.
 421
 422         -- Now process any SPECIALIZE pragmas for the methods
 423     let
 424         spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
 425     in
 426     tcPragmaSigs spec_sigs              `thenTc` \ (_, spec_binds, spec_lie) ->
 427
 428         -- Create the result bindings
 429     let
 430         dict_bind    = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 431         method_binds = andMonoBinds method_binds_s
 432
 433         main_bind
 434           = MonoBind (
 435                 AbsBinds
 436                  inst_tyvars'
 437                  dfun_arg_dicts_ids
 438                  [(inst_tyvars', RealId dfun_id, this_dict_id)]
 439                  (super_binds   `AndMonoBinds`
 440                   method_binds  `AndMonoBinds`
 441                   dict_bind))
 442                 [] recursive            -- Recursive to play safe
 443     in
 444     returnTc (const_lie `plusLIE` spec_lie,
 445               main_bind `ThenBinds` spec_binds)
 446 \end{code}
 447
 448 The next function looks for a method binding; if there isn't one it
 449 manufactures one that just calls the global default method.
 450
 451 See the notes under default decls in TcClassDcl.lhs.
 452
 453 \begin{code}
 454 getDefmRhs :: Class -> Int -> RenamedHsExpr
 455 getDefmRhs clas idx = HsVar (getName (classDefaultMethodId clas idx))
 456 \end{code}
 457
 458
 459 %************************************************************************
 460 %*                                                                      *
 461 \subsection{Processing each method}
 462 %*                                                                      *
 463 %************************************************************************
 464
 465 \begin{code}
 466 tcMethodBind
 467         :: (Int -> RenamedHsExpr)                       -- Function mapping a tag to default RHS
 468         -> TcType s                                     -- Instance type
 469         -> RenamedMonoBinds                             -- Method binding
 470         -> (Id, Int)                                    -- Selector ID (and its 0-indexed tag)
 471                                                         --  for which binding is wanted
 472         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 473
 474 tcMethodBind deflt_fn inst_ty meth_binds (sel_id, idx)
 475   = newMethod origin (RealId sel_id) [inst_ty]  `thenNF_Tc` \ meth@(_, TcId meth_id) ->
 476     tcInstSigTcType (idType meth_id)            `thenNF_Tc` \ (tyvars', rho_ty') ->
 477     let
 478         meth_name    = getName meth_id
 479         default_bind = PatMonoBind (VarPatIn meth_name)
 480                                    (GRHSsAndBindsIn [OtherwiseGRHS (deflt_fn idx) noSrcLoc] EmptyBinds)
 481                                    noSrcLoc
 482
 483         (op_name, op_bind) = case go (getOccName sel_id) meth_binds of
 484                                 Just stuff -> stuff
 485                                 Nothing    -> (meth_name, default_bind)
 486
 487         (theta', tau') = splitRhoTy rho_ty'
 488         sig_info       = TySigInfo op_name meth_id tyvars' theta' tau' noSrcLoc
 489     in
 490     tcBindWithSigs [op_name] op_bind [sig_info]
 491                    nonRecursive (\_ -> NoPragmaInfo)    `thenTc` \ (binds, insts, _) ->
 492
 493     returnTc (binds, insts, meth)
 494   where
 495     origin = InstanceDeclOrigin         -- Poor
 496
 497     go occ EmptyMonoBinds       = Nothing
 498     go occ (AndMonoBinds b1 b2) = go occ b1 `seqMaybe` go occ b2
 499
 500     go occ b@(FunMonoBind op_name _ _ locn)          | nameOccName op_name == occ = Just (op_name, b)
 501                                                      | otherwise                  = Nothing
 502     go occ b@(PatMonoBind (VarPatIn op_name) _ locn) | nameOccName op_name == occ = Just (op_name, b)
 503                                                      | otherwise                  = Nothing
 504     go occ other = panic "Urk! Bad instance method binding"
 505 \end{code}
 506
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511 \subsection{Type-checking specialise instance pragmas}
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 \begin{code}
 516 {- LATER
 517 tcSpecInstSigs :: E -> CE -> TCE
 518                -> Bag InstInfo          -- inst decls seen (declared and derived)
 519                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 520                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 521
 522 tcSpecInstSigs e ce tce inst_infos []
 523   = returnTc emptyBag
 524
 525 tcSpecInstSigs e ce tce inst_infos sigs
 526   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 527     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 528     returnTc spec_inst_infos
 529   where
 530     tc_inst_spec_sigs inst_mapper []
 531       = returnNF_Tc emptyBag
 532     tc_inst_spec_sigs inst_mapper (sig:sigs)
 533       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 534         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 535         returnNF_Tc (info_sig `unionBags` info_sigs)
 536
 537 tcSpecInstSig :: E -> CE -> TCE
 538               -> Bag InstInfo
 539               -> InstanceMapper
 540               -> RenamedSpecInstSig
 541               -> NF_TcM (Bag InstInfo)
 542
 543 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 544   = recoverTc emptyBag                  (
 545     tcAddSrcLoc src_loc                 (
 546     let
 547         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 548
 549         -- Make some new type variables, named as in the specialised instance type
 550         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 551         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 552     in
 553     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 554                                 `thenTc` \ inst_ty ->
 555     let
 556         maybe_tycon = case maybeAppDataTyCon inst_ty of
 557                          Just (tc,_,_) -> Just tc
 558                          Nothing       -> Nothing
 559
 560         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 561     in
 562         -- Check that we have a local instance declaration to specialise
 563     checkMaybeTc maybe_unspec_inst
 564             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 565
 566         -- Create tvs to substitute for tmpls while simplifying the context
 567     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 568     let
 569         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 570                        _ _ binds _ uprag) = maybe_unspec_inst
 571
 572         subst = case matchTy unspec_inst_ty inst_ty of
 573                      Just subst -> subst
 574                      Nothing    -> panic "tcSpecInstSig:matchTy"
 575
 576         subst_theta    = instantiateThetaTy subst unspec_theta
 577         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 578
 579         mk_spec_origin clas ty
 580           = InstanceSpecOrigin inst_mapper clas ty src_loc
 581         -- I'm VERY SUSPICIOUS ABOUT THIS
 582         -- the inst-mapper is in a knot at this point so it's no good
 583         -- looking at it in tcSimplify...
 584     in
 585     tcSimplifyThetas mk_spec_origin subst_tv_theta
 586                                 `thenTc` \ simpl_tv_theta ->
 587     let
 588         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 589
 590         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 591         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 592     in
 593     mkInstanceRelatedIds
 594                          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 PprDebug simpl_theta,
 601                           if null simpl_theta then empty else ptext SLIT("=>"),
 602                           ppr PprDebug clas,
 603                           pprParendGenType PprDebug inst_ty],
 604                    hsep [ptext SLIT("        derived from:"),
 605                           if null unspec_theta then empty else ppr PprDebug unspec_theta,
 606                           if null unspec_theta then empty else ptext SLIT("=>"),
 607                           ppr PprDebug clas,
 608                           pprParendGenType PprDebug 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 (maybeAppDataTyCon 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 (maybeAppDataTyCon 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 dfun_name clas inst_tau
 660         -- TYCON CHECK
 661   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 662   = failTc (instTypeErr inst_tau)
 663
 664         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 665   | not (isLocallyDefined dfun_name)
 666   = returnTc (inst_tycon,arg_tys)
 667
 668         -- TYVARS CHECK
 669   | not (all isTyVarTy arg_tys ||
 670          opt_GlasgowExts)
 671   = failTc (instTypeErr inst_tau)
 672
 673         -- DERIVING CHECK
 674         -- It is obviously illegal to have an explicit instance
 675         -- for something that we are also planning to `derive'
 676         -- Though we can have an explicit instance which is more
 677         -- specific than the derived instance
 678   | clas `derivedFor` inst_tycon
 679     && all isTyVarTy arg_tys
 680   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 681
 682   |     -- CCALL CHECK
 683         -- A user declaration of a CCallable/CReturnable instance
 684         -- must be for a "boxed primitive" type.
 685     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 686     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 687   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 688
 689   | otherwise
 690   = returnTc (inst_tycon,arg_tys)
 691
 692   where
 693     (possible_tycon, arg_tys) = splitAppTys inst_tau
 694     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 695     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 696
 697 -- These conditions come directly from what the DsCCall is capable of.
 698 -- Totally grotesque.  Green card should solve this.
 699
 700 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 701                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 702                       ty `eqTy` stringTy ||
 703                       byte_arr_thing
 704   where
 705     byte_arr_thing = case maybeAppDataTyCon ty of
 706                         Just (tycon, ty_args, [data_con]) ->
 707 --                              pprTrace "cc1" (sep [ppr PprDebug tycon, ppr PprDebug data_con,
 708 --                                                     sep (map (ppr PprDebug) data_con_arg_tys)])(
 709                                 length data_con_arg_tys == 2 &&
 710                                 maybeToBool maybe_arg2_tycon &&
 711 --                              pprTrace "cc2" (sep [ppr PprDebug arg2_tycon]) (
 712                                 (arg2_tycon == byteArrayPrimTyCon ||
 713                                  arg2_tycon == mutableByteArrayPrimTyCon)
 714 --                              ))
 715                              where
 716                                 data_con_arg_tys = dataConArgTys data_con ty_args
 717                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 718                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 719                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 720
 721                         other -> False
 722
 723 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 724                         -- Or, a data type with a single nullary constructor
 725                       case (maybeAppDataTyCon ty) of
 726                         Just (tycon, tys_applied, [data_con])
 727                                 -> isNullaryDataCon data_con
 728                         other -> False
 729 \end{code}
 730
 731 \begin{code}
 732
 733 instTypeErr ty sty
 734   = case ty of
 735       SynTy tc _ _ -> hcat [ptext SLIT("The type synonym `"), ppr sty tc, rest_of_msg]
 736       TyVarTy tv   -> hcat [ptext SLIT("The type variable `"), ppr sty tv, rest_of_msg]
 737       other        -> hcat [ptext SLIT("The type `"), ppr sty ty, rest_of_msg]
 738   where
 739     rest_of_msg = ptext SLIT("' cannot be used as an instance type.")
 740
 741 instBndrErr bndr clas sty
 742   = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
 743
 744 derivingWhenInstanceExistsErr clas tycon sty
 745   = hang (hsep [ptext SLIT("Deriving class"),
 746                        ppr sty clas,
 747                        ptext SLIT("type"), ppr sty tycon])
 748          4 (ptext SLIT("when an explicit instance exists"))
 749
 750 derivingWhenInstanceImportedErr inst_mod clas tycon sty
 751   = hang (hsep [ptext SLIT("Deriving class"),
 752                        ppr sty clas,
 753                        ptext SLIT("type"), ppr sty tycon])
 754          4 (hsep [ptext SLIT("when an instance declared in module"),
 755                        pp_mod, ptext SLIT("has been imported")])
 756   where
 757     pp_mod = hsep [ptext SLIT("module"), ptext inst_mod]
 758
 759 nonBoxedPrimCCallErr clas inst_ty sty
 760   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 761          4 (hsep [ ptext SLIT("class"), ppr sty clas, ptext SLIT("type"),
 762                         ppr sty inst_ty])
 763
 764 omitDefaultMethodWarn clas_op clas_name inst_ty sty
 765   = hsep [ptext SLIT("Warning: Omitted default method for"),
 766            ppr sty clas_op, ptext SLIT("in instance"),
 767            text clas_name, pprParendGenType sty inst_ty]
 768
 769 instMethodNotInClassErr occ clas sty
 770   = hang (ptext SLIT("Instance mentions a method not in the class"))
 771          4 (hsep [ptext SLIT("class"), ppr sty clas, ptext SLIT("method"),
 772                        ppr sty occ])
 773
 774 patMonoBindsCtxt pbind sty
 775   = hang (ptext SLIT("In a pattern binding:"))
 776          4 (ppr sty pbind)
 777
 778 methodSigCtxt name ty sty
 779   = hang (hsep [ptext SLIT("When matching the definition of class method"),
 780                        ppr sty name, ptext SLIT("to its signature :") ])
 781          4 (ppr sty ty)
 782
 783 bindSigCtxt method_ids sty
 784   = hang (ptext SLIT("When checking type signatures for: "))
 785          4 (hsep (punctuate comma (map (ppr sty) method_ids)))
 786
 787 superClassSigCtxt sty
 788   = ptext SLIT("When checking superclass constraints on instance declaration")
 789
 790 \end{code}