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