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