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