ghc/compiler/typecheck/TcInstDcls.lhs

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