ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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(..),
  16                           HsExpr(..), InPat(..), HsLit(..), Sig(..),
  17                           collectMonoBinders, andMonoBindList
  18                         )
  19 import RnHsSyn          ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
  20 import TcHsSyn          ( TcMonoBinds,
  21                           maybeBoxedPrimType
  22                         )
  23
  24 import TcBinds          ( tcPragmaSigs )
  25 import TcClassDcl       ( tcMethodBind, badMethodErr )
  26 import TcMonad
  27 import RnMonad          ( RnNameSupply )
  28 import Inst             ( Inst, InstOrigin(..),
  29                           newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
  30 import TcDeriv          ( tcDeriving )
  31 import TcEnv            ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
  32                           tcAddImportedIdInfo, tcInstId
  33                         )
  34 import TcInstUtil       ( InstInfo(..), classDataCon )
  35 import TcMonoType       ( tcHsTopType )
  36 import TcSimplify       ( tcSimplifyAndCheck )
  37 import TcType           ( TcTyVar, zonkTcTyVarBndr )
  38
  39 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  40                           foldBag, bagToList, Bag
  41                         )
  42 import CmdLineOpts      ( opt_GlasgowExts, opt_AllowUndecidableInstances )
  43 import Class            ( classBigSig, Class )
  44 import Var              ( setIdInfo, idName, idType, Id, TyVar )
  45 import DataCon          ( isNullaryDataCon, dataConArgTys, dataConId )
  46 import Maybes           ( maybeToBool, catMaybes, expectJust )
  47 import MkId             ( mkDictFunId )
  48 import Name             ( nameOccName, isLocallyDefined, Module,
  49                           NamedThing(..)
  50                         )
  51 import PrelVals         ( eRROR_ID )
  52 import PprType          ( pprConstraint )
  53 import SrcLoc           ( SrcLoc )
  54 import TyCon            ( isSynTyCon, isDataTyCon, tyConDerivings )
  55 import Type             ( Type, isUnLiftedType, mkTyVarTys,
  56                           splitSigmaTy, isTyVarTy,
  57                           splitTyConApp_maybe, splitDictTy_maybe,
  58                           splitAlgTyConApp_maybe,
  59                           tyVarsOfTypes, substTopTheta
  60                         )
  61 import VarEnv           ( zipVarEnv )
  62 import VarSet           ( mkVarSet, varSetElems )
  63 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  64 import TysWiredIn       ( stringTy )
  65 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
  66 import Outputable
  67 \end{code}
  68
  69 Typechecking instance declarations is done in two passes. The first
  70 pass, made by @tcInstDecls1@, collects information to be used in the
  71 second pass.
  72
  73 This pre-processed info includes the as-yet-unprocessed bindings
  74 inside the instance declaration.  These are type-checked in the second
  75 pass, when the class-instance envs and GVE contain all the info from
  76 all the instance and value decls.  Indeed that's the reason we need
  77 two passes over the instance decls.
  78
  79
  80 Here is the overall algorithm.
  81 Assume that we have an instance declaration
  82
  83     instance c => k (t tvs) where b
  84
  85 \begin{enumerate}
  86 \item
  87 $LIE_c$ is the LIE for the context of class $c$
  88 \item
  89 $betas_bar$ is the free variables in the class method type, excluding the
  90    class variable
  91 \item
  92 $LIE_cop$ is the LIE constraining a particular class method
  93 \item
  94 $tau_cop$ is the tau type of a class method
  95 \item
  96 $LIE_i$ is the LIE for the context of instance $i$
  97 \item
  98 $X$ is the instance constructor tycon
  99 \item
 100 $gammas_bar$ is the set of type variables of the instance
 101 \item
 102 $LIE_iop$ is the LIE for a particular class method instance
 103 \item
 104 $tau_iop$ is the tau type for this instance of a class method
 105 \item
 106 $alpha$ is the class variable
 107 \item
 108 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 109 \item
 110 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 111 \end{enumerate}
 112
 113 ToDo: Update the list above with names actually in the code.
 114
 115 \begin{enumerate}
 116 \item
 117 First, make the LIEs for the class and instance contexts, which means
 118 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 119 and make LIElistI and LIEI.
 120 \item
 121 Then process each method in turn.
 122 \item
 123 order the instance methods according to the ordering of the class methods
 124 \item
 125 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 126 \item
 127 Create final dictionary function from bindings generated already
 128 \begin{pseudocode}
 129 df = lambda inst_tyvars
 130        lambda LIEI
 131          let Bop1
 132              Bop2
 133              ...
 134              Bopn
 135          and dbinds_super
 136               in <op1,op2,...,opn,sd1,...,sdm>
 137 \end{pseudocode}
 138 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 139 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 140 \end{enumerate}
 141
 142 \begin{code}
 143 tcInstDecls1 :: ValueEnv                -- Contains IdInfo for dfun ids
 144              -> [RenamedHsDecl]
 145              -> Module                  -- module name for deriving
 146              -> RnNameSupply                    -- for renaming derivings
 147              -> TcM s (Bag InstInfo,
 148                        RenamedHsBinds)
 149
 150 tcInstDecls1 unf_env decls mod_name rn_name_supply
 151   =     -- Do the ordinary instance declarations
 152     mapNF_Tc (tcInstDecl1 unf_env mod_name)
 153              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 154     let
 155         decl_inst_info = unionManyBags inst_info_bags
 156     in
 157         -- Handle "derived" instances; note that we only do derivings
 158         -- for things in this module; we ignore deriving decls from
 159         -- interfaces!
 160     tcDeriving mod_name rn_name_supply decl_inst_info
 161                         `thenTc` \ (deriv_inst_info, deriv_binds) ->
 162
 163     let
 164         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 165     in
 166     returnTc (full_inst_info, deriv_binds)
 167
 168
 169 tcInstDecl1 :: ValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 170
 171 tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 172   =     -- Prime error recovery, set source location
 173     recoverNF_Tc (returnNF_Tc emptyBag) $
 174     tcAddSrcLoc src_loc                 $
 175
 176         -- Type-check all the stuff before the "where"
 177     tcHsTopType poly_ty                 `thenTc` \ poly_ty' ->
 178     let
 179         (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
 180         (clas, inst_tys)         = case splitDictTy_maybe dict_ty of
 181                                      Nothing   -> pprPanic "tcInstDecl1" (ppr poly_ty)
 182                                      Just pair -> pair
 183     in
 184
 185         -- Check for respectable instance type, and context
 186     scrutiniseInstanceHead clas inst_tys        `thenNF_Tc_`
 187     mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
 188
 189         -- Make the dfun id and constant-method ids
 190     let
 191         dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
 192
 193         -- Add info from interface file
 194         final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
 195     in
 196     returnTc (unitBag (InstInfo clas tyvars inst_tys theta
 197                                 final_dfun_id
 198                                 binds src_loc uprags))
 199 \end{code}
 200
 201
 202 %************************************************************************
 203 %*                                                                      *
 204 \subsection{Type-checking instance declarations, pass 2}
 205 %*                                                                      *
 206 %************************************************************************
 207
 208 \begin{code}
 209 tcInstDecls2 :: Bag InstInfo
 210              -> NF_TcM s (LIE, TcMonoBinds)
 211
 212 tcInstDecls2 inst_decls
 213   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
 214   where
 215     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 216                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 217                       returnNF_Tc (lie1 `plusLIE` lie2,
 218                                    binds1 `AndMonoBinds` binds2)
 219 \end{code}
 220
 221
 222 ======= New documentation starts here (Sept 92)  ==============
 223
 224 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 225 the dictionary function for this instance declaration.  For example
 226 \begin{verbatim}
 227         instance Foo a => Foo [a] where
 228                 op1 x = ...
 229                 op2 y = ...
 230 \end{verbatim}
 231 might generate something like
 232 \begin{verbatim}
 233         dfun.Foo.List dFoo_a = let op1 x = ...
 234                                    op2 y = ...
 235                                in
 236                                    Dict [op1, op2]
 237 \end{verbatim}
 238
 239 HOWEVER, if the instance decl has no context, then it returns a
 240 bigger @HsBinds@ with declarations for each method.  For example
 241 \begin{verbatim}
 242         instance Foo [a] where
 243                 op1 x = ...
 244                 op2 y = ...
 245 \end{verbatim}
 246 might produce
 247 \begin{verbatim}
 248         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 249         const.Foo.op1.List a x = ...
 250         const.Foo.op2.List a y = ...
 251 \end{verbatim}
 252 This group may be mutually recursive, because (for example) there may
 253 be no method supplied for op2 in which case we'll get
 254 \begin{verbatim}
 255         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 256 \end{verbatim}
 257 that is, the default method applied to the dictionary at this type.
 258
 259 What we actually produce in either case is:
 260
 261         AbsBinds [a] [dfun_theta_dicts]
 262                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 263                  { d = (sd1,sd2, ..., op1, op2, ...)
 264                    op1 = ...
 265                    op2 = ...
 266                  }
 267
 268 The "maybe" says that we only ask AbsBinds to make global constant methods
 269 if the dfun_theta is empty.
 270
 271
 272 For an instance declaration, say,
 273
 274         instance (C1 a, C2 b) => C (T a b) where
 275                 ...
 276
 277 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 278 function whose type is
 279
 280         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 281
 282 Notice that we pass it the superclass dictionaries at the instance type; this
 283 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 284 is the @dfun_theta@ below.
 285
 286 First comes the easy case of a non-local instance decl.
 287
 288 \begin{code}
 289 tcInstDecl2 :: InstInfo -> NF_TcM s (LIE, TcMonoBinds)
 290
 291 tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
 292                       inst_decl_theta
 293                       dfun_id monobinds
 294                       locn uprags)
 295   | not (isLocallyDefined dfun_id)
 296   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 297
 298 {-
 299   -- I deleted this "optimisation" because when importing these
 300   -- instance decls the renamer would look for the dfun bindings and they weren't there.
 301   -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
 302   -- even though it's never used.
 303
 304         -- This case deals with CCallable etc, which don't need any bindings
 305   | isNoDictClass clas
 306   = returnNF_Tc (emptyLIE, EmptyBinds)
 307 -}
 308
 309   | otherwise
 310   =      -- Prime error recovery
 311     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
 312     tcAddSrcLoc locn                                       $
 313
 314         -- Instantiate the instance decl with tc-style type variables
 315     tcInstId dfun_id            `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
 316     let
 317         (clas, inst_tys')       = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
 318
 319         origin                  = InstanceDeclOrigin
 320
 321         (class_tyvars,
 322          sc_theta, sc_sel_ids,
 323          op_sel_ids, defm_ids)  = classBigSig clas
 324
 325         -- Instantiate the theta found in the original instance decl
 326         inst_decl_theta' = substTopTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
 327                                          inst_decl_theta
 328
 329          -- Instantiate the super-class context with inst_tys
 330         sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys') sc_theta
 331     in
 332          -- Create dictionary Ids from the specified instance contexts.
 333     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 334     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 335     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 336     newDicts origin [(clas,inst_tys')]  `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 337
 338          -- Check that all the method bindings come from this class
 339     let
 340         check_from_this_class (bndr, loc)
 341           | nameOccName bndr `elem` sel_names = returnNF_Tc ()
 342           | otherwise                         = tcAddSrcLoc loc $
 343                                                 addErrTc (badMethodErr bndr clas)
 344         sel_names = map getOccName op_sel_ids
 345         bndrs = bagToList (collectMonoBinders monobinds)
 346     in
 347     mapNF_Tc check_from_this_class bndrs                `thenNF_Tc_`
 348
 349     tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
 350         tcExtendGlobalValEnv (catMaybes defm_ids) (
 351                 -- Default-method Ids may be mentioned in synthesised RHSs
 352
 353         mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta'
 354                                      monobinds uprags True)
 355                        (op_sel_ids `zip` defm_ids)
 356     ))                  `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
 357
 358         -- Deal with SPECIALISE instance pragmas
 359     let
 360         dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
 361     in
 362     tcExtendGlobalValEnv [dfun_id] (
 363         tcPragmaSigs dfun_prags
 364     )                                   `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
 365
 366         -- Check the overloading constraints of the methods and superclasses
 367
 368         -- tcMethodBind has checked that the class_tyvars havn't
 369         -- been unified with each other or another type, but we must
 370         -- still zonk them
 371     mapNF_Tc zonkTcTyVarBndr inst_tyvars'       `thenNF_Tc` \ zonked_inst_tyvars ->
 372     let
 373         inst_tyvars_set = mkVarSet zonked_inst_tyvars
 374
 375         (meth_lies, meth_ids) = unzip meth_lies_w_ids
 376
 377                  -- These insts are in scope; quite a few, eh?
 378         avail_insts = this_dict                 `plusLIE`
 379                       dfun_arg_dicts            `plusLIE`
 380                       sc_dicts                  `plusLIE`
 381                       unionManyBags meth_lies
 382
 383         methods_lie = plusLIEs insts_needed_s
 384     in
 385
 386         -- Ditto method bindings
 387     tcAddErrCtxt methodCtxt (
 388       tcSimplifyAndCheck
 389                  (ptext SLIT("instance declaration context"))
 390                  inst_tyvars_set                        -- Local tyvars
 391                  avail_insts
 392                  methods_lie
 393     )                                            `thenTc` \ (const_lie1, lie_binds1) ->
 394
 395         -- Check that we *could* construct the superclass dictionaries,
 396         -- even though we are *actually* going to pass the superclass dicts in;
 397         -- the check ensures that the caller will never have
 398         --a problem building them.
 399     tcAddErrCtxt superClassCtxt (
 400       tcSimplifyAndCheck
 401                  (ptext SLIT("instance declaration context"))
 402                  inst_tyvars_set                -- Local tyvars
 403                  inst_decl_dicts                -- The instance dictionaries available
 404                  sc_dicts                       -- The superclass dicationaries reqd
 405     )                                   `thenTc` \ _ ->
 406                                                 -- Ignore the result; we're only doing
 407                                                 -- this to make sure it can be done.
 408
 409         -- Now do the simplification again, this time to get the
 410         -- bindings; this time we use an enhanced "avails"
 411         -- Ignore errors because they come from the *previous* tcSimplify
 412     discardErrsTc (
 413         tcSimplifyAndCheck
 414                  (ptext SLIT("instance declaration context"))
 415                  inst_tyvars_set
 416                  dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
 417                                         -- get bound by just selecting from this_dict!!
 418                  sc_dicts
 419     )                                            `thenTc` \ (const_lie2, lie_binds2) ->
 420
 421
 422         -- Create the result bindings
 423     let
 424         dict_constr   = classDataCon clas
 425         scs_and_meths = sc_dict_ids ++ meth_ids
 426
 427         dict_rhs
 428           | null scs_and_meths
 429           =     -- Blatant special case for CCallable, CReturnable
 430                 -- If the dictionary is empty then we should never
 431                 -- select anything from it, so we make its RHS just
 432                 -- emit an error message.  This in turn means that we don't
 433                 -- mention the constructor, which doesn't exist for CCallable, CReturnable
 434                 -- Hardly beautiful, but only three extra lines.
 435             HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
 436                   (HsLitOut (HsString msg) stringTy)
 437
 438           | otherwise   -- The common case
 439           = foldl HsApp (TyApp (HsVar (dataConId dict_constr)) inst_tys')
 440                                (map HsVar (sc_dict_ids ++ meth_ids))
 441                 -- We don't produce a binding for the dict_constr; instead we
 442                 -- rely on the simplifier to unfold this saturated application
 443                 -- We do this rather than generate an HsCon directly, because
 444                 -- it means that the special cases (e.g. dictionary with only one
 445                 -- member) are dealt with by the common MkId.mkDataConId code rather
 446                 -- than needing to be repeated here.
 447
 448           where
 449             msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
 450
 451         dict_bind    = VarMonoBind this_dict_id dict_rhs
 452         method_binds = andMonoBindList method_binds_s
 453
 454         final_dfun_id = setIdInfo dfun_id (prag_info_fn (idName dfun_id))
 455                                 -- Pretty truesome
 456         main_bind
 457           = AbsBinds
 458                  zonked_inst_tyvars
 459                  dfun_arg_dicts_ids
 460                  [(inst_tyvars', final_dfun_id, this_dict_id)]
 461                  (lie_binds1    `AndMonoBinds`
 462                   lie_binds2    `AndMonoBinds`
 463                   method_binds  `AndMonoBinds`
 464                   dict_bind)
 465     in
 466     returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
 467               main_bind `AndMonoBinds` prag_binds)
 468 \end{code}
 469
 470
 471 %************************************************************************
 472 %*                                                                      *
 473 \subsection{Checking for a decent instance type}
 474 %*                                                                      *
 475 %************************************************************************
 476
 477 @scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
 478 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 479
 480 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 481 flag is on, or (2)~the instance is imported (they must have been
 482 compiled elsewhere). In these cases, we let them go through anyway.
 483
 484 We can also have instances for functions: @instance Foo (a -> b) ...@.
 485
 486 \begin{code}
 487 scrutiniseInstanceConstraint (clas, tys)
 488   |  all isTyVarTy tys
 489   || opt_AllowUndecidableInstances = returnNF_Tc ()
 490   | otherwise                      = addErrTc (instConstraintErr clas tys)
 491
 492 scrutiniseInstanceHead clas inst_taus
 493   |     -- CCALL CHECK (a).... urgh!
 494         -- To verify that a user declaration of a CCallable/CReturnable
 495         -- instance is OK, we must be able to see the constructor(s)
 496         -- of the instance type (see next guard.)
 497         --
 498         -- We flag this separately to give a more precise error msg.
 499         --
 500      (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
 501   && is_alg_tycon_app && not constructors_visible
 502   = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
 503
 504   |     -- CCALL CHECK (b)
 505         -- A user declaration of a CCallable/CReturnable instance
 506         -- must be for a "boxed primitive" type.
 507     (getUnique clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
 508     (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
 509   = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 510
 511         -- DERIVING CHECK
 512         -- It is obviously illegal to have an explicit instance
 513         -- for something that we are also planning to `derive'
 514   | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
 515   = addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
 516            -- Kind check will have ensured inst_taus is of length 1
 517
 518         -- Allow anything for AllowUndecidableInstances
 519   | opt_AllowUndecidableInstances
 520   = returnNF_Tc ()
 521
 522         -- If GlasgowExts then check at least one isn't a type variable
 523   | opt_GlasgowExts
 524   = if all isTyVarTy inst_taus then
 525         addErrTc (instTypeErr clas inst_taus (text "There must be at least one non-type-variable in the instance head"))
 526     else
 527         returnNF_Tc ()
 528
 529         -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
 530   |  not (length inst_taus == 1 &&
 531           maybeToBool maybe_tycon_app &&        -- Yes, there's a type constuctor
 532           not (isSynTyCon tycon) &&             -- ...but not a synonym
 533           all isTyVarTy arg_tys &&              -- Applied to type variables
 534           length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
 535                  -- This last condition checks that all the type variables are distinct
 536      )
 537   = addErrTc (instTypeErr clas inst_taus
 538                         (text "the instance type must be of form (T a b c)" $$
 539                          text "where T is not a synonym, and a,b,c are distinct type variables")
 540     )
 541
 542   | otherwise
 543   = returnNF_Tc ()
 544
 545   where
 546     (first_inst_tau : _)       = inst_taus
 547
 548         -- Stuff for algebraic or -> type
 549     maybe_tycon_app       = splitTyConApp_maybe first_inst_tau
 550     Just (tycon, arg_tys) = maybe_tycon_app
 551
 552         -- Stuff for an *algebraic* data type
 553     alg_tycon_app_maybe            = splitAlgTyConApp_maybe first_inst_tau
 554                                         -- The "Alg" part looks through synonyms
 555     is_alg_tycon_app               = maybeToBool alg_tycon_app_maybe
 556     Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
 557
 558     constructors_visible = not (null data_cons)
 559
 560
 561 -- These conditions come directly from what the DsCCall is capable of.
 562 -- Totally grotesque.  Green card should solve this.
 563
 564 ccallable_type   ty = isUnLiftedType ty ||                              -- Allow CCallable Int# etc
 565                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 566                       ty == stringTy ||
 567                       byte_arr_thing
 568   where
 569     byte_arr_thing = case splitAlgTyConApp_maybe ty of
 570                         Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
 571                                 length data_con_arg_tys == 2 &&
 572                                 maybeToBool maybe_arg2_tycon &&
 573                                 (arg2_tycon == byteArrayPrimTyCon ||
 574                                  arg2_tycon == mutableByteArrayPrimTyCon)
 575                              where
 576                                 data_con_arg_tys = dataConArgTys data_con ty_args
 577                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 578                                 maybe_arg2_tycon = splitTyConApp_maybe data_con_arg_ty2
 579                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 580
 581                         other -> False
 582
 583 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 584                         -- Or, a data type with a single nullary constructor
 585                       case (splitAlgTyConApp_maybe ty) of
 586                         Just (tycon, tys_applied, [data_con])
 587                                 -> isNullaryDataCon data_con
 588                         other -> False
 589 \end{code}
 590
 591 \begin{code}
 592 instConstraintErr clas tys
 593   = hang (ptext SLIT("Illegal constaint") <+>
 594           quotes (pprConstraint clas tys) <+>
 595           ptext SLIT("in instance context"))
 596          4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
 597
 598 instTypeErr clas tys msg
 599   = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
 600          nest 4 (parens msg)
 601     ]
 602
 603 derivingWhenInstanceExistsErr clas tycon
 604   = hang (hsep [ptext SLIT("Deriving class"),
 605                        quotes (ppr clas),
 606                        ptext SLIT("type"), quotes (ppr tycon)])
 607          4 (ptext SLIT("when an explicit instance exists"))
 608
 609 nonBoxedPrimCCallErr clas inst_ty
 610   = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
 611          4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
 612                         ppr inst_ty])
 613
 614 {-
 615   Declaring CCallable & CReturnable instances in a module different
 616   from where the type was defined. Caused by importing data type
 617   abstractly (either programmatically or by the renamer being over-eager
 618   in its pruning.)
 619 -}
 620 invisibleDataConPrimCCallErr clas inst_ty
 621   = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
 622                 ptext SLIT("not visible when checking"),
 623                 quotes (ppr clas), ptext SLIT("instance")])
 624         4 (hsep [text "(Try either importing", ppr inst_ty,
 625                  text "non-abstractly or compile using -fno-prune-tydecls ..)"])
 626
 627 methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
 628 superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
 629 \end{code}