f0096376e3c1b1a43b85e098b97b7cac49b1c751
[ghc.git] / compiler / typecheck / TcTyClsDecls.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %
5
6 TcTyClsDecls: Typecheck type and class declarations
7
8 \begin{code}
9 module TcTyClsDecls (
10         tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
11     ) where
12
13 #include "HsVersions.h"
14
15 import HsSyn
16 import HscTypes
17 import BuildTyCl
18 import TcUnify
19 import TcRnMonad
20 import TcEnv
21 import TcTyDecls
22 import TcClassDcl
23 import TcHsType
24 import TcMType
25 import TcType
26 import TysWiredIn       ( unitTy )
27 import Type
28 import Generics
29 import Class
30 import TyCon
31 import DataCon
32 import Id
33 import MkId             ( mkDefaultMethodId )
34 import MkCore           ( rEC_SEL_ERROR_ID )
35 import IdInfo
36 import Var
37 import VarSet
38 import Name
39 import Outputable
40 import Maybes
41 import Unify
42 import Util
43 import SrcLoc
44 import ListSetOps
45 import Digraph
46 import DynFlags
47 import FastString
48 import Unique           ( mkBuiltinUnique )
49 import BasicTypes
50
51 import Bag
52 import Control.Monad
53 import Data.List
54 \end{code}
55
56
57 %************************************************************************
58 %*                                                                      *
59 \subsection{Type checking for type and class declarations}
60 %*                                                                      *
61 %************************************************************************
62
63 Dealing with a group
64 ~~~~~~~~~~~~~~~~~~~~
65 Consider a mutually-recursive group, binding 
66 a type constructor T and a class C.
67
68 Step 1:         getInitialKind
69         Construct a KindEnv by binding T and C to a kind variable 
70
71 Step 2:         kcTyClDecl
72         In that environment, do a kind check
73
74 Step 3: Zonk the kinds
75
76 Step 4:         buildTyConOrClass
77         Construct an environment binding T to a TyCon and C to a Class.
78         a) Their kinds comes from zonking the relevant kind variable
79         b) Their arity (for synonyms) comes direct from the decl
80         c) The funcional dependencies come from the decl
81         d) The rest comes a knot-tied binding of T and C, returned from Step 4
82         e) The variances of the tycons in the group is calculated from 
83                 the knot-tied stuff
84
85 Step 5:         tcTyClDecl1
86         In this environment, walk over the decls, constructing the TyCons and Classes.
87         This uses in a strict way items (a)-(c) above, which is why they must
88         be constructed in Step 4. Feed the results back to Step 4.
89         For this step, pass the is-recursive flag as the wimp-out flag
90         to tcTyClDecl1.
91         
92
93 Step 6:         Extend environment
94         We extend the type environment with bindings not only for the TyCons and Classes,
95         but also for their "implicit Ids" like data constructors and class selectors
96
97 Step 7:         checkValidTyCl
98         For a recursive group only, check all the decls again, just
99         to check all the side conditions on validity.  We could not
100         do this before because we were in a mutually recursive knot.
101
102 Identification of recursive TyCons
103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104 The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
105 @TyThing@s.
106
107 Identifying a TyCon as recursive serves two purposes
108
109 1.  Avoid infinite types.  Non-recursive newtypes are treated as
110 "transparent", like type synonyms, after the type checker.  If we did
111 this for all newtypes, we'd get infinite types.  So we figure out for
112 each newtype whether it is "recursive", and add a coercion if so.  In
113 effect, we are trying to "cut the loops" by identifying a loop-breaker.
114
115 2.  Avoid infinite unboxing.  This is nothing to do with newtypes.
116 Suppose we have
117         data T = MkT Int T
118         f (MkT x t) = f t
119 Well, this function diverges, but we don't want the strictness analyser
120 to diverge.  But the strictness analyser will diverge because it looks
121 deeper and deeper into the structure of T.   (I believe there are
122 examples where the function does something sane, and the strictness
123 analyser still diverges, but I can't see one now.)
124
125 Now, concerning (1), the FC2 branch currently adds a coercion for ALL
126 newtypes.  I did this as an experiment, to try to expose cases in which
127 the coercions got in the way of optimisations.  If it turns out that we
128 can indeed always use a coercion, then we don't risk recursive types,
129 and don't need to figure out what the loop breakers are.
130
131 For newtype *families* though, we will always have a coercion, so they
132 are always loop breakers!  So you can easily adjust the current
133 algorithm by simply treating all newtype families as loop breakers (and
134 indeed type families).  I think.
135
136 \begin{code}
137 tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
138                    -> TcM (TcGblEnv,         -- Input env extended by types and classes 
139                                              -- and their implicit Ids,DataCons
140                            HsValBinds Name,  -- Renamed bindings for record selectors
141                            [Id])             -- Default method ids
142
143 -- Fails if there are any errors
144
145 tcTyAndClassDecls boot_details allDecls
146   = checkNoErrs $       -- The code recovers internally, but if anything gave rise to
147                         -- an error we'd better stop now, to avoid a cascade
148     do  {       -- Omit instances of type families; they are handled together
149                 -- with the *heads* of class instances
150         ; let decls = filter (not . isFamInstDecl . unLoc) allDecls
151
152                 -- First check for cyclic type synonysm or classes
153                 -- See notes with checkCycleErrs
154         ; checkCycleErrs decls
155         ; mod <- getModule
156         ; traceTc "tcTyAndCl" (ppr mod)
157         ; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
158           do    { let { -- Seperate ordinary synonyms from all other type and
159                         -- class declarations and add all associated type
160                         -- declarations from type classes.  The latter is
161                         -- required so that the temporary environment for the
162                         -- knot includes all associated family declarations.
163                       ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc)
164                                                    decls
165                       ; alg_at_decls           = concatMap addATs alg_decls
166                       }
167                         -- Extend the global env with the knot-tied results
168                         -- for data types and classes
169                         -- 
170                         -- We must populate the environment with the loop-tied
171                         -- T's right away, because the kind checker may "fault
172                         -- in" some type  constructors that recursively
173                         -- mention T
174                 ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss
175                 ; tcExtendRecEnv gbl_things $ do
176
177                         -- Kind-check the declarations
178                 { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
179
180                 ; let { -- Calculate rec-flag
181                       ; calc_rec  = calcRecFlags boot_details rec_alg_tyclss
182                       ; tc_decl   = addLocM (tcTyClDecl calc_rec) }
183
184                         -- Type-check the type synonyms, and extend the envt
185                 ; syn_tycons <- tcSynDecls kc_syn_decls
186                 ; tcExtendGlobalEnv syn_tycons $ do
187
188                         -- Type-check the data types and classes
189                 { alg_tyclss <- mapM tc_decl kc_alg_decls
190                 ; return (syn_tycons, concat alg_tyclss)
191             }}})
192         -- Finished with knot-tying now
193         -- Extend the environment with the finished things
194         ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
195
196         -- Perform the validity check
197         { traceTc "ready for validity check" empty
198         ; mapM_ (addLocM checkValidTyCl) decls
199         ; traceTc "done" empty
200    
201         -- Add the implicit things;
202         -- we want them in the environment because 
203         -- they may be mentioned in interface files
204         -- NB: All associated types and their implicit things will be added a
205         --     second time here.  This doesn't matter as the definitions are
206         --     the same.
207         ; let { implicit_things = concatMap implicitTyThings alg_tyclss
208               ; rec_sel_binds   = mkRecSelBinds alg_tyclss
209               ; dm_ids          = mkDefaultMethodIds alg_tyclss }
210         ; traceTc "Adding types and classes" $ vcat
211                  [ ppr alg_tyclss 
212                  , text "and" <+> ppr implicit_things ]
213         ; env <- tcExtendGlobalEnv implicit_things getGblEnv
214         ; return (env, rec_sel_binds, dm_ids) }
215     }
216   where
217     -- Pull associated types out of class declarations, to tie them into the
218     -- knot above.  
219     -- NB: We put them in the same place in the list as `tcTyClDecl' will
220     --     eventually put the matching `TyThing's.  That's crucial; otherwise,
221     --     the two argument lists of `mkGlobalThings' don't match up.
222     addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
223     addATs decl                                  = [decl]
224
225 mkGlobalThings :: [LTyClDecl Name]      -- The decls
226                -> [TyThing]             -- Knot-tied, in 1-1 correspondence with the decls
227                -> [(Name,TyThing)]
228 -- Driven by the Decls, and treating the TyThings lazily
229 -- make a TypeEnv for the new things
230 mkGlobalThings decls things
231   = map mk_thing (decls `zipLazy` things)
232   where
233     mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
234          = (name, AClass cl)
235     mk_thing (L _ decl, ~(ATyCon tc))
236          = (tcdName decl, ATyCon tc)
237 \end{code}
238
239
240 %************************************************************************
241 %*                                                                      *
242                Type checking family instances
243 %*                                                                      *
244 %************************************************************************
245
246 Family instances are somewhat of a hybrid.  They are processed together with
247 class instance heads, but can contain data constructors and hence they share a
248 lot of kinding and type checking code with ordinary algebraic data types (and
249 GADTs).
250
251 \begin{code}
252 tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
253 tcFamInstDecl top_lvl (L loc decl)
254   =     -- Prime error recovery, set source location
255     setSrcSpan loc                              $
256     tcAddDeclCtxt decl                          $
257     do { -- type family instances require -XTypeFamilies
258          -- and can't (currently) be in an hs-boot file
259        ; type_families <- doptM Opt_TypeFamilies
260        ; is_boot  <- tcIsHsBoot   -- Are we compiling an hs-boot file?
261        ; checkTc type_families $ badFamInstDecl (tcdLName decl)
262        ; checkTc (not is_boot) $ badBootFamInstDeclErr
263
264          -- Perform kind and type checking
265        ; tc <- tcFamInstDecl1 decl
266        ; checkValidTyCon tc     -- Remember to check validity;
267                                 -- no recursion to worry about here
268
269        -- Check that toplevel type instances are not for associated types.
270        ; when (isTopLevel top_lvl && isAssocFamily tc)
271               (addErr $ assocInClassErr (tcdName decl))
272
273        ; return (ATyCon tc) }
274
275 isAssocFamily :: TyCon -> Bool  -- Is an assocaited type
276 isAssocFamily tycon
277   = case tyConFamInst_maybe tycon of
278           Nothing       -> panic "isAssocFamily: no family?!?"
279           Just (fam, _) -> isTyConAssoc fam
280
281 assocInClassErr :: Name -> SDoc
282 assocInClassErr name
283  = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
284    ptext (sLit "must be inside a class instance")
285
286
287
288 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
289
290   -- "type instance"
291 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
292   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
293     do { -- check that the family declaration is for a synonym
294          checkTc (isFamilyTyCon family) (notFamily family)
295        ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
296
297        ; -- (1) kind check the right-hand side of the type equation
298        ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
299                   -- ToDo: the ExpKind could be better
300
301          -- we need the exact same number of type parameters as the family
302          -- declaration 
303        ; let famArity = tyConArity family
304        ; checkTc (length k_typats == famArity) $ 
305            wrongNumberOfParmsErr famArity
306
307          -- (2) type check type equation
308        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
309        ; t_typats <- mapM tcHsKindedType k_typats
310        ; t_rhs    <- tcHsKindedType k_rhs
311
312          -- (3) check the well-formedness of the instance
313        ; checkValidTypeInst t_typats t_rhs
314
315          -- (4) construct representation tycon
316        ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
317        ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
318                        (typeKind t_rhs) 
319                        NoParentTyCon (Just (family, t_typats))
320        }}
321
322   -- "newtype instance" and "data instance"
323 tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
324                              tcdCons = cons})
325   = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
326     do { -- check that the family declaration is for the right kind
327          checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
328        ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
329
330        ; -- (1) kind check the data declaration as usual
331        ; k_decl <- kcDataDecl decl k_tvs
332        ; let k_ctxt = tcdCtxt k_decl
333              k_cons = tcdCons k_decl
334
335          -- result kind must be '*' (otherwise, we have too few patterns)
336        ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
337
338          -- (2) type check indexed data type declaration
339        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
340        ; unbox_strict <- doptM Opt_UnboxStrictFields
341
342          -- kind check the type indexes and the context
343        ; t_typats     <- mapM tcHsKindedType k_typats
344        ; stupid_theta <- tcHsKindedContext k_ctxt
345
346          -- (3) Check that
347          --     (a) left-hand side contains no type family applications
348          --         (vanilla synonyms are fine, though, and we checked for
349          --         foralls earlier)
350        ; mapM_ checkTyFamFreeness t_typats
351
352          -- Check that we don't use GADT syntax in H98 world
353        ; gadt_ok <- doptM Opt_GADTs
354        ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
355
356          --     (b) a newtype has exactly one constructor
357        ; checkTc (new_or_data == DataType || isSingleton k_cons) $
358                  newtypeConError tc_name (length k_cons)
359
360          -- (4) construct representation tycon
361        ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
362        ; let ex_ok = True       -- Existentials ok for type families!
363        ; fixM (\ rep_tycon -> do 
364              { let orig_res_ty = mkTyConApp fam_tycon t_typats
365              ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
366                                        (t_tvs, orig_res_ty) k_cons
367              ; tc_rhs <-
368                  case new_or_data of
369                    DataType -> return (mkDataTyConRhs data_cons)
370                    NewType  -> ASSERT( not (null data_cons) )
371                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
372              ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
373                              False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
374                  -- We always assume that indexed types are recursive.  Why?
375                  -- (1) Due to their open nature, we can never be sure that a
376                  -- further instance might not introduce a new recursive
377                  -- dependency.  (2) They are always valid loop breakers as
378                  -- they involve a coercion.
379              })
380        }}
381        where
382          h98_syntax = case cons of      -- All constructors have same shape
383                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
384                         _ -> True
385
386 tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
387
388 -- Kind checking of indexed types
389 -- -
390
391 -- Kind check type patterns and kind annotate the embedded type variables.
392 --
393 -- * Here we check that a type instance matches its kind signature, but we do
394 --   not check whether there is a pattern for each type index; the latter
395 --   check is only required for type synonym instances.
396
397 kcIdxTyPats :: TyClDecl Name
398             -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
399                -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
400             -> TcM a
401 kcIdxTyPats decl thing_inside
402   = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
403     do { let tc_name = tcdLName decl
404        ; fam_tycon <- tcLookupLocatedTyCon tc_name
405        ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
406              ; hs_typats        = fromJust $ tcdTyPats decl }
407
408          -- we may not have more parameters than the kind indicates
409        ; checkTc (length kinds >= length hs_typats) $
410            tooManyParmsErr (tcdLName decl)
411
412          -- type functions can have a higher-kinded result
413        ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
414        ; typats <- zipWithM kcCheckLHsType hs_typats 
415                             [ EK kind (EkArg (ppr tc_name) n) 
416                             | (kind,n) <- kinds `zip` [1..]]
417        ; thing_inside tvs typats resultKind fam_tycon
418        }
419 \end{code}
420
421
422 %************************************************************************
423 %*                                                                      *
424                 Kind checking
425 %*                                                                      *
426 %************************************************************************
427
428 We need to kind check all types in the mutually recursive group
429 before we know the kind of the type variables.  For example:
430
431 class C a where
432    op :: D b => a -> b -> b
433
434 class D c where
435    bop :: (Monad c) => ...
436
437 Here, the kind of the locally-polymorphic type variable "b"
438 depends on *all the uses of class D*.  For example, the use of
439 Monad c in bop's type signature means that D must have kind Type->Type.
440
441 However type synonyms work differently.  They can have kinds which don't
442 just involve (->) and *:
443         type R = Int#           -- Kind #
444         type S a = Array# a     -- Kind * -> #
445         type T a b = (# a,b #)  -- Kind * -> * -> (# a,b #)
446 So we must infer their kinds from their right-hand sides *first* and then
447 use them, whereas for the mutually recursive data types D we bring into
448 scope kind bindings D -> k, where k is a kind variable, and do inference.
449
450 Type families
451 ~~~~~~~~~~~~~
452 This treatment of type synonyms only applies to Haskell 98-style synonyms.
453 General type functions can be recursive, and hence, appear in `alg_decls'.
454
455 The kind of a type family is solely determinded by its kind signature;
456 hence, only kind signatures participate in the construction of the initial
457 kind environment (as constructed by `getInitialKind').  In fact, we ignore
458 instances of families altogether in the following.  However, we need to
459 include the kinds of associated families into the construction of the
460 initial kind environment.  (This is handled by `allDecls').
461
462 \begin{code}
463 kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)]
464             -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)])
465 kcTyClDecls syn_decls alg_decls
466   = do  {       -- First extend the kind env with each data type, class, and
467                 -- indexed type, mapping them to a type variable
468           let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls]
469         ; alg_kinds <- mapM getInitialKind initialKindDecls
470         ; tcExtendKindEnv alg_kinds $ do
471
472                 -- Now kind-check the type synonyms, in dependency order
473                 -- We do these differently to data type and classes,
474                 -- because a type synonym can be an unboxed type
475                 --      type Foo = Int#
476                 -- and a kind variable can't unify with UnboxedTypeKind
477                 -- So we infer their kinds in dependency order
478         { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
479         ; tcExtendKindEnv syn_kinds $  do
480
481                 -- Now kind-check the data type, class, and kind signatures,
482                 -- returning kind-annotated decls; we don't kind-check
483                 -- instances of indexed types yet, but leave this to
484                 -- `tcInstDecls1'
485         { kc_alg_decls <- mapM (wrapLocM kcTyClDecl)
486                             (filter (not . isFamInstDecl . unLoc) alg_decls)
487
488         ; return (kc_syn_decls, kc_alg_decls) }}}
489   where
490     -- get all declarations relevant for determining the initial kind
491     -- environment
492     allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at 
493                                                       | L _ at <- ats
494                                                       , isFamilyDecl at]
495     allDecls decl | isFamInstDecl decl = []
496                   | otherwise          = [decl]
497
498 ------------------------------------------------------------------------
499 getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
500 -- Only for data type, class, and indexed type declarations
501 -- Get as much info as possible from the data, class, or indexed type decl,
502 -- so as to maximise usefulness of error messages
503 getInitialKind decl
504   = do  { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
505         ; res_kind  <- mk_res_kind decl
506         ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
507   where
508     mk_arg_kind (UserTyVar _ _)      = newKindVar
509     mk_arg_kind (KindedTyVar _ kind) = return kind
510
511     mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
512     mk_res_kind (TyData   { tcdKindSig = Just kind }) = return kind
513         -- On GADT-style declarations we allow a kind signature
514         --      data T :: *->* where { ... }
515     mk_res_kind _ = return liftedTypeKind
516
517
518 ----------------
519 kcSynDecls :: [SCC (LTyClDecl Name)] 
520            -> TcM ([LTyClDecl Name],    -- Kind-annotated decls
521                    [(Name,TcKind)])     -- Kind bindings
522 kcSynDecls []
523   = return ([], [])
524 kcSynDecls (group : groups)
525   = do  { (decl,  nk)  <- kcSynDecl group
526         ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
527         ; return (decl:decls, nk:nks) }
528                         
529 ----------------
530 kcSynDecl :: SCC (LTyClDecl Name) 
531            -> TcM (LTyClDecl Name,      -- Kind-annotated decls
532                    (Name,TcKind))       -- Kind bindings
533 kcSynDecl (AcyclicSCC (L loc decl))
534   = tcAddDeclCtxt decl  $
535     kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
536     do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
537                         <+> brackets (ppr k_tvs))
538        ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
539        ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
540        ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
541        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
542                  (unLoc (tcdLName decl), tc_kind)) })
543
544 kcSynDecl (CyclicSCC decls)
545   = do { recSynErr decls; failM }       -- Fail here to avoid error cascade
546                                         -- of out-of-scope tycons
547
548 ------------------------------------------------------------------------
549 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
550         -- Not used for type synonyms (see kcSynDecl)
551
552 kcTyClDecl decl@(TyData {})
553   = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance
554     kcTyClDeclBody decl $
555       kcDataDecl decl
556
557 kcTyClDecl decl@(TyFamily {})
558   = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl      
559
560 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
561   = kcTyClDeclBody decl $ \ tvs' ->
562     do  { ctxt' <- kcHsContext ctxt     
563         ; ats'  <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
564         ; sigs' <- mapM (wrapLocM kc_sig) sigs
565         ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
566                         tcdATs = ats'}) }
567   where
568     kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
569                                    ; return (TypeSig nm op_ty') }
570     kc_sig other_sig          = return other_sig
571
572 kcTyClDecl decl@(ForeignType {})
573   = return decl
574
575 kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
576
577 kcTyClDeclBody :: TyClDecl Name
578                -> ([LHsTyVarBndr Name] -> TcM a)
579                -> TcM a
580 -- getInitialKind has made a suitably-shaped kind for the type or class
581 -- Unpack it, and attribute those kinds to the type variables
582 -- Extend the env with bindings for the tyvars, taken from
583 -- the kind of the tycon/class.  Give it to the thing inside, and 
584 -- check the result kind matches
585 kcTyClDeclBody decl thing_inside
586   = tcAddDeclCtxt decl          $
587     do  { tc_ty_thing <- tcLookupLocated (tcdLName decl)
588         ; let tc_kind    = case tc_ty_thing of
589                              AThing k -> k
590                              _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
591               (kinds, _) = splitKindFunTys tc_kind
592               hs_tvs     = tcdTyVars decl
593               kinded_tvs = ASSERT( length kinds >= length hs_tvs )
594                            zipWith add_kind hs_tvs kinds
595         ; tcExtendKindEnvTvs kinded_tvs thing_inside }
596   where
597     add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
598     add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
599
600 -- Kind check a data declaration, assuming that we already extended the
601 -- kind environment with the type variables of the left-hand side (these
602 -- kinded type variables are also passed as the second parameter).
603 --
604 kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
605 kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
606            tvs
607   = do  { ctxt' <- kcHsContext ctxt     
608         ; cons' <- mapM (wrapLocM kc_con_decl) cons
609         ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
610   where
611     -- doc comments are typechecked to Nothing here
612     kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
613                                   , con_cxt = ex_ctxt, con_details = details, con_res = res })
614       = addErrCtxt (dataConCtxt name)   $ 
615         kcHsTyVars ex_tvs $ \ex_tvs' -> do
616         do { ex_ctxt' <- kcHsContext ex_ctxt
617            ; details' <- kc_con_details details 
618            ; res'     <- case res of
619                 ResTyH98 -> return ResTyH98
620                 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
621            ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
622                               , con_details = details', con_res = res' }) }
623
624     kc_con_details (PrefixCon btys) 
625         = do { btys' <- mapM kc_larg_ty btys 
626              ; return (PrefixCon btys') }
627     kc_con_details (InfixCon bty1 bty2) 
628         = do { bty1' <- kc_larg_ty bty1
629              ; bty2' <- kc_larg_ty bty2
630              ; return (InfixCon bty1' bty2') }
631     kc_con_details (RecCon fields) 
632         = do { fields' <- mapM kc_field fields
633              ; return (RecCon fields') }
634
635     kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
636                                            ; return (ConDeclField fld bty' d) }
637
638     kc_larg_ty bty = case new_or_data of
639                         DataType -> kcHsSigType bty
640                         NewType  -> kcHsLiftedSigType bty
641         -- Can't allow an unlifted type for newtypes, because we're effectively
642         -- going to remove the constructor while coercing it to a lifted type.
643         -- And newtypes can't be bang'd
644 kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
645
646 -- Kind check a family declaration or type family default declaration.
647 --
648 kcFamilyDecl :: [LHsTyVarBndr Name]  -- tyvars of enclosing class decl if any
649              -> TyClDecl Name -> TcM (TyClDecl Name)
650 kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
651   = kcTyClDeclBody decl $ \tvs' ->
652     do { mapM_ unifyClassParmKinds tvs'
653        ; return (decl {tcdTyVars = tvs', 
654                        tcdKind = kind `mplus` Just liftedTypeKind})
655                        -- default result kind is '*'
656        }
657   where
658     unifyClassParmKinds (L _ tv) 
659       | (n,k) <- hsTyVarNameKind tv
660       , Just classParmKind <- lookup n classTyKinds 
661       = unifyKind k classParmKind
662       | otherwise = return ()
663     classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
664
665 kcFamilyDecl _ (TySynonym {})              -- type family defaults
666   = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
667 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
668 \end{code}
669
670
671 %************************************************************************
672 %*                                                                      *
673 \subsection{Type checking}
674 %*                                                                      *
675 %************************************************************************
676
677 \begin{code}
678 tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
679 tcSynDecls [] = return []
680 tcSynDecls (decl : decls) 
681   = do { syn_tc <- addLocM tcSynDecl decl
682        ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
683        ; return (syn_tc : syn_tcs) }
684
685   -- "type"
686 tcSynDecl :: TyClDecl Name -> TcM TyThing
687 tcSynDecl
688   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
689   = tcTyVarBndrs tvs            $ \ tvs' -> do 
690     { traceTc "tcd1" (ppr tc_name) 
691     ; rhs_ty' <- tcHsKindedType rhs_ty
692     ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') 
693                              (typeKind rhs_ty') NoParentTyCon  Nothing
694     ; return (ATyCon tycon) 
695     }
696 tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
697
698 --------------------
699 tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
700
701 tcTyClDecl calc_isrec decl
702   = tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl)
703
704   -- "type family" declarations
705 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
706 tcTyClDecl1 parent _calc_isrec 
707   (TyFamily {tcdFlavour = TypeFamily, 
708              tcdLName = L _ tc_name, tcdTyVars = tvs,
709              tcdKind = Just kind}) -- NB: kind at latest added during kind checking
710   = tcTyVarBndrs tvs  $ \ tvs' -> do 
711   { traceTc "type family:" (ppr tc_name) 
712
713         -- Check that we don't use families without -XTypeFamilies
714   ; idx_tys <- doptM Opt_TypeFamilies
715   ; checkTc idx_tys $ badFamInstDecl tc_name
716
717   ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
718   ; return [ATyCon tycon]
719   }
720
721   -- "data family" declaration
722 tcTyClDecl1 parent _calc_isrec 
723   (TyFamily {tcdFlavour = DataFamily, 
724              tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
725   = tcTyVarBndrs tvs  $ \ tvs' -> do 
726   { traceTc "data family:" (ppr tc_name) 
727   ; extra_tvs <- tcDataKindSig mb_kind
728   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
729
730
731         -- Check that we don't use families without -XTypeFamilies
732   ; idx_tys <- doptM Opt_TypeFamilies
733   ; checkTc idx_tys $ badFamInstDecl tc_name
734
735   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
736                DataFamilyTyCon Recursive False True 
737                parent Nothing
738   ; return [ATyCon tycon]
739   }
740
741   -- "newtype" and "data"
742   -- NB: not used for newtype/data instances (whether associated or not)
743 tcTyClDecl1 parent calc_isrec
744   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
745            tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
746   = tcTyVarBndrs tvs    $ \ tvs' -> do 
747   { extra_tvs <- tcDataKindSig mb_ksig
748   ; let final_tvs = tvs' ++ extra_tvs
749   ; stupid_theta <- tcHsKindedContext ctxt
750   ; want_generic <- doptM Opt_Generics
751   ; unbox_strict <- doptM Opt_UnboxStrictFields
752   ; empty_data_decls <- doptM Opt_EmptyDataDecls
753   ; kind_signatures <- doptM Opt_KindSignatures
754   ; existential_ok <- doptM Opt_ExistentialQuantification
755   ; gadt_ok      <- doptM Opt_GADTs
756   ; is_boot      <- tcIsHsBoot  -- Are we compiling an hs-boot file?
757   ; let ex_ok = existential_ok || gadt_ok       -- Data cons can have existential context
758
759         -- Check that we don't use GADT syntax in H98 world
760   ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
761
762         -- Check that we don't use kind signatures without Glasgow extensions
763   ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
764
765         -- Check that the stupid theta is empty for a GADT-style declaration
766   ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
767
768         -- Check that a newtype has exactly one constructor
769         -- Do this before checking for empty data decls, so that
770         -- we don't suggest -XEmptyDataDecls for newtypes
771   ; checkTc (new_or_data == DataType || isSingleton cons) 
772             (newtypeConError tc_name (length cons))
773
774         -- Check that there's at least one condecl,
775         -- or else we're reading an hs-boot file, or -XEmptyDataDecls
776   ; checkTc (not (null cons) || empty_data_decls || is_boot)
777             (emptyConDeclsErr tc_name)
778     
779   ; tycon <- fixM (\ tycon -> do 
780         { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
781         ; data_cons <- tcConDecls unbox_strict ex_ok 
782                                   tycon (final_tvs, res_ty) cons
783         ; tc_rhs <-
784             if null cons && is_boot     -- In a hs-boot file, empty cons means
785             then return AbstractTyCon   -- "don't know"; hence Abstract
786             else case new_or_data of
787                    DataType -> return (mkDataTyConRhs data_cons)
788                    NewType  -> ASSERT( not (null data_cons) )
789                                mkNewTyConRhs tc_name tycon (head data_cons)
790         ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
791             (want_generic && canDoGenerics data_cons) (not h98_syntax) 
792             parent Nothing
793         })
794   ; return [ATyCon tycon]
795   }
796   where
797     is_rec   = calc_isrec tc_name
798     h98_syntax = consUseH98Syntax cons
799
800 tcTyClDecl1 _parent calc_isrec 
801   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
802               tcdCtxt = ctxt, tcdMeths = meths,
803               tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
804   = tcTyVarBndrs tvs            $ \ tvs' -> do 
805   { ctxt' <- tcHsKindedContext ctxt
806   ; fds' <- mapM (addLocM tc_fundep) fundeps
807   ; sig_stuff <- tcClassSigs class_name sigs meths
808   ; clas <- fixM $ \ clas -> do
809             { let       -- This little knot is just so we can get
810                         -- hold of the name of the class TyCon, which we
811                         -- need to look up its recursiveness
812                     tycon_name = tyConName (classTyCon clas)
813                     tc_isrec = calc_isrec tycon_name
814             ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
815             -- NB: 'ats' only contains "type family" and "data family"
816             --     declarations as well as type family defaults
817             ; buildClass False {- Must include unfoldings for selectors -}
818                          class_name tvs' ctxt' fds' (concat atss')
819                          sig_stuff tc_isrec }
820   ; return (AClass clas : map ATyCon (classATs clas))
821       -- NB: Order is important due to the call to `mkGlobalThings' when
822       --     tying the the type and class declaration type checking knot.
823   }
824   where
825     tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
826                                 ; tvs2' <- mapM tcLookupTyVar tvs2 ;
827                                 ; return (tvs1', tvs2') }
828
829 tcTyClDecl1 _ _
830   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
831   = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
832
833 tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
834
835 -----------------------------------
836 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
837            -> [LConDecl Name] -> TcM [DataCon]
838 tcConDecls unbox ex_ok rep_tycon res_tmpl cons
839   = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
840
841 tcConDecl :: Bool               -- True <=> -funbox-strict_fields
842           -> Bool               -- True <=> -XExistentialQuantificaton or -XGADTs
843           -> TyCon              -- Representation tycon
844           -> ([TyVar], Type)    -- Return type template (with its template tyvars)
845           -> ConDecl Name 
846           -> TcM DataCon
847
848 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl        -- Data types
849           (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
850                    , con_details = details, con_res = res_ty })
851   = addErrCtxt (dataConCtxt name)       $ 
852     tcTyVarBndrs tvs                    $ \ tvs' -> do 
853     { ctxt' <- tcHsKindedContext ctxt
854     ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
855               (badExistential name)
856     ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
857     ; let 
858         tc_datacon is_infix field_lbls btys
859           = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
860                ; buildDataCon (unLoc name) is_infix
861                     stricts field_lbls
862                     univ_tvs ex_tvs eq_preds ctxt' arg_tys
863                     res_ty' rep_tycon }
864                 -- NB:  we put data_tc, the type constructor gotten from the
865                 --      constructor type signature into the data constructor;
866                 --      that way checkValidDataCon can complain if it's wrong.
867
868     ; case details of
869         PrefixCon btys     -> tc_datacon False [] btys
870         InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
871         RecCon fields      -> tc_datacon False field_names btys
872                            where
873                               field_names = map (unLoc . cd_fld_name) fields
874                               btys        = map cd_fld_type fields
875     }
876
877 -- Example
878 --   data instance T (b,c) where 
879 --      TI :: forall e. e -> T (e,e)
880 --
881 -- The representation tycon looks like this:
882 --   data :R7T b c where 
883 --      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
884 -- In this case orig_res_ty = T (e,e)
885
886 tcResultType :: ([TyVar], Type) -- Template for result type; e.g.
887                                 -- data instance T [a] b c = ...  
888                                 --      gives template ([a,b,c], T [a] b c)
889              -> [TyVar]         -- where MkT :: forall x y z. ...
890              -> ResType Name
891              -> TcM ([TyVar],           -- Universal
892                      [TyVar],           -- Existential (distinct OccNames from univs)
893                      [(TyVar,Type)],    -- Equality predicates
894                      Type)              -- Typechecked return type
895         -- We don't check that the TyCon given in the ResTy is
896         -- the same as the parent tycon, becuase we are in the middle
897         -- of a recursive knot; so it's postponed until checkValidDataCon
898
899 tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
900   = return (tmpl_tvs, dc_tvs, [], res_ty)
901         -- In H98 syntax the dc_tvs are the existential ones
902         --      data T a b c = forall d e. MkT ...
903         -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs
904
905 tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
906         -- E.g.  data T [a] b c where
907         --         MkT :: forall x y z. T [(x,y)] z z
908         -- Then we generate
909         --      Univ tyvars     Eq-spec
910         --          a              a~(x,y)
911         --          b              b~z
912         --          z              
913         -- Existentials are the leftover type vars: [x,y]
914         -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
915   = do  { res_ty' <- tcHsKindedType res_ty
916         ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
917
918                 -- /Lazily/ figure out the univ_tvs etc
919                 -- Each univ_tv is either a dc_tv or a tmpl_tv
920               (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
921               choose tmpl (univs, eqs)
922                 | Just ty <- lookupTyVar subst tmpl 
923                 = case tcGetTyVar_maybe ty of
924                     Just tv | not (tv `elem` univs)
925                             -> (tv:univs,   eqs)
926                     _other  -> (tmpl:univs, (tmpl,ty):eqs)
927                 | otherwise = pprPanic "tcResultType" (ppr res_ty)
928               ex_tvs = dc_tvs `minusList` univ_tvs
929
930         ; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
931   where
932         -- NB: tmpl_tvs and dc_tvs are distinct, but
933         -- we want them to be *visibly* distinct, both for
934         -- interface files and general confusion.  So rename
935         -- the tc_tvs, since they are not used yet (no 
936         -- consequential renaming needed)
937     (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
938     init_occ_env       = initTidyOccEnv (map getOccName dc_tvs)
939     tidy_one env tv    = (env', setTyVarName tv (tidyNameOcc name occ'))
940               where
941                  name = tyVarName tv
942                  (env', occ') = tidyOccName env (getOccName name) 
943
944 consUseH98Syntax :: [LConDecl a] -> Bool
945 consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
946 consUseH98Syntax _                                             = True
947                  -- All constructors have same shape
948
949 -------------------
950 tcConArg :: Bool                -- True <=> -funbox-strict_fields
951            -> LHsType Name
952            -> TcM (TcType, HsBang)
953 tcConArg unbox_strict bty
954   = do  { arg_ty <- tcHsBangType bty
955         ; let bang = getBangStrictness bty
956         ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
957         ; return (arg_ty, strict_mark) }
958
959 -- We attempt to unbox/unpack a strict field when either:
960 --   (i)  The field is marked '!!', or
961 --   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
962 --
963 -- We have turned off unboxing of newtypes because coercions make unboxing 
964 -- and reboxing more complicated
965 chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
966 chooseBoxingStrategy unbox_strict_fields arg_ty bang
967   = case bang of
968         HsNoBang                        -> HsNoBang
969         HsUnpack                        -> can_unbox HsUnpackFailed arg_ty
970         HsStrict | unbox_strict_fields  -> can_unbox HsStrict       arg_ty
971                  | otherwise            -> HsStrict
972         HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
973                           -- Source code never has shtes
974   where
975     can_unbox :: HsBang -> TcType -> HsBang
976     -- Returns   HsUnpack  if we can unpack arg_ty
977     --           fail_bang if we know what arg_ty is but we can't unpack it
978     --           HsStrict  if it's abstract, so we don't know whether or not we can unbox it
979     can_unbox fail_bang arg_ty 
980        = case splitTyConApp_maybe arg_ty of
981             Nothing -> fail_bang
982
983             Just (arg_tycon, tycon_args) 
984               | isAbstractTyCon arg_tycon -> HsStrict   
985                       -- See Note [Don't complain about UNPACK on abstract TyCons]
986               | not (isRecursiveTyCon arg_tycon)        -- Note [Recusive unboxing]
987               , isProductTyCon arg_tycon 
988                     -- We can unbox if the type is a chain of newtypes 
989                     -- with a product tycon at the end
990               -> if isNewTyCon arg_tycon 
991                  then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
992                  else HsUnpack
993
994               | otherwise -> fail_bang
995 \end{code}
996
997 Note [Don't complain about UNPACK on abstract TyCons]
998 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
999 We are going to complain about UnpackFailed, but if we say
1000    data T = MkT {-# UNPACK #-} !Wobble
1001 and Wobble is a newtype imported from a module that was compiled 
1002 without optimisation, we don't want to complain. Because it might
1003 be fine when optimsation is on.  I think this happens when Haddock
1004 is working over (say) GHC souce files.
1005
1006 Note [Recursive unboxing]
1007 ~~~~~~~~~~~~~~~~~~~~~~~~~
1008 Be careful not to try to unbox this!
1009         data T = MkT !T Int
1010 But it's the *argument* type that matters. This is fine:
1011         data S = MkS S !Int
1012 because Int is non-recursive.
1013
1014
1015 %************************************************************************
1016 %*                                                                      *
1017                 Validity checking
1018 %*                                                                      *
1019 %************************************************************************
1020
1021 Validity checking is done once the mutually-recursive knot has been
1022 tied, so we can look at things freely.
1023
1024 \begin{code}
1025 checkCycleErrs :: [LTyClDecl Name] -> TcM ()
1026 checkCycleErrs tyclss
1027   | null cls_cycles
1028   = return ()
1029   | otherwise
1030   = do  { mapM_ recClsErr cls_cycles
1031         ; failM }       -- Give up now, because later checkValidTyCl
1032                         -- will loop if the synonym is recursive
1033   where
1034     cls_cycles = calcClassCycles tyclss
1035
1036 checkValidTyCl :: TyClDecl Name -> TcM ()
1037 -- We do the validity check over declarations, rather than TyThings
1038 -- only so that we can add a nice context with tcAddDeclCtxt
1039 checkValidTyCl decl
1040   = tcAddDeclCtxt decl $
1041     do  { thing <- tcLookupLocatedGlobal (tcdLName decl)
1042         ; traceTc "Validity of" (ppr thing)     
1043         ; case thing of
1044             ATyCon tc -> checkValidTyCon tc
1045             AClass cl -> checkValidClass cl 
1046             _ -> panic "checkValidTyCl"
1047         ; traceTc "Done validity of" (ppr thing)        
1048         }
1049
1050 -------------------------
1051 -- For data types declared with record syntax, we require
1052 -- that each constructor that has a field 'f' 
1053 --      (a) has the same result type
1054 --      (b) has the same type for 'f'
1055 -- module alpha conversion of the quantified type variables
1056 -- of the constructor.
1057 --
1058 -- Note that we allow existentials to match becuase the
1059 -- fields can never meet. E.g
1060 --      data T where
1061 --        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
1062 --        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T  
1063 -- Here we do not complain about f1,f2 because they are existential
1064
1065 checkValidTyCon :: TyCon -> TcM ()
1066 checkValidTyCon tc 
1067   | isSynTyCon tc 
1068   = case synTyConRhs tc of
1069       SynFamilyTyCon {} -> return ()
1070       SynonymTyCon ty   -> checkValidType syn_ctxt ty
1071   | otherwise
1072   = do  -- Check the context on the data decl
1073     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
1074         
1075         -- Check arg types of data constructors
1076     mapM_ (checkValidDataCon tc) data_cons
1077
1078         -- Check that fields with the same name share a type
1079     mapM_ check_fields groups
1080
1081   where
1082     syn_ctxt  = TySynCtxt name
1083     name      = tyConName tc
1084     data_cons = tyConDataCons tc
1085
1086     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
1087     cmp_fld (f1,_) (f2,_) = f1 `compare` f2
1088     get_fields con = dataConFieldLabels con `zip` repeat con
1089         -- dataConFieldLabels may return the empty list, which is fine
1090
1091     -- See Note [GADT record selectors] in MkId.lhs
1092     -- We must check (a) that the named field has the same 
1093     --                   type in each constructor
1094     --               (b) that those constructors have the same result type
1095     --
1096     -- However, the constructors may have differently named type variable
1097     -- and (worse) we don't know how the correspond to each other.  E.g.
1098     --     C1 :: forall a b. { f :: a, g :: b } -> T a b
1099     --     C2 :: forall d c. { f :: c, g :: c } -> T c d
1100     -- 
1101     -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
1102     -- result type against other candidates' types BOTH WAYS ROUND.
1103     -- If they magically agrees, take the substitution and
1104     -- apply them to the latter ones, and see if they match perfectly.
1105     check_fields ((label, con1) : other_fields)
1106         -- These fields all have the same name, but are from
1107         -- different constructors in the data type
1108         = recoverM (return ()) $ mapM_ checkOne other_fields
1109                 -- Check that all the fields in the group have the same type
1110                 -- NB: this check assumes that all the constructors of a given
1111                 -- data type use the same type variables
1112         where
1113         (tvs1, _, _, res1) = dataConSig con1
1114         ts1 = mkVarSet tvs1
1115         fty1 = dataConFieldType con1 label
1116
1117         checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
1118             = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
1119                  ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
1120             where        
1121                 (tvs2, _, _, res2) = dataConSig con2
1122                 ts2 = mkVarSet tvs2
1123                 fty2 = dataConFieldType con2 label
1124     check_fields [] = panic "checkValidTyCon/check_fields []"
1125
1126 checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
1127                  -> Type -> Type -> Type -> Type -> TcM ()
1128 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
1129   = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
1130         ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
1131   where
1132     mb_subst1 = tcMatchTy tvs1 res1 res2
1133     mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
1134
1135 -------------------------------
1136 checkValidDataCon :: TyCon -> DataCon -> TcM ()
1137 checkValidDataCon tc con
1138   = setSrcSpan (srcLocSpan (getSrcLoc con))     $
1139     addErrCtxt (dataConCtxt con)                $ 
1140     do  { traceTc "Validity of data con" (ppr con)
1141         ; let tc_tvs = tyConTyVars tc
1142               res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
1143               actual_res_ty = dataConOrigResTy con
1144         ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
1145                                 res_ty_tmpl
1146                                 actual_res_ty))
1147                   (badDataConTyCon con res_ty_tmpl actual_res_ty)
1148         ; checkValidMonoType (dataConOrigResTy con)
1149                 -- Disallow MkT :: T (forall a. a->a)
1150                 -- Reason: it's really the argument of an equality constraint
1151         ; checkValidType ctxt (dataConUserType con)
1152         ; when (isNewTyCon tc) (checkNewDataCon con)
1153         ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
1154     }
1155   where
1156     ctxt = ConArgCtxt (dataConName con) 
1157     check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
1158     check_bang _                   = return ()
1159
1160     cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
1161                            , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
1162
1163 -------------------------------
1164 checkNewDataCon :: DataCon -> TcM ()
1165 -- Checks for the data constructor of a newtype
1166 checkNewDataCon con
1167   = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
1168                 -- One argument
1169         ; checkTc (null eq_spec) (newtypePredError con)
1170                 -- Return type is (T a b c)
1171         ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
1172                 -- No existentials
1173         ; checkTc (not (any isBanged (dataConStrictMarks con))) 
1174                   (newtypeStrictError con)
1175                 -- No strictness
1176     }
1177   where
1178     (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
1179
1180 -------------------------------
1181 checkValidClass :: Class -> TcM ()
1182 checkValidClass cls
1183   = do  { constrained_class_methods <- doptM Opt_ConstrainedClassMethods
1184         ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
1185         ; fundep_classes <- doptM Opt_FunctionalDependencies
1186
1187         -- Check that the class is unary, unless GlaExs
1188         ; checkTc (notNull tyvars) (nullaryClassErr cls)
1189         ; checkTc (multi_param_type_classes || unary) (classArityErr cls)
1190         ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
1191
1192         -- Check the super-classes
1193         ; checkValidTheta (ClassSCCtxt (className cls)) theta
1194
1195         -- Check the class operations
1196         ; mapM_ (check_op constrained_class_methods) op_stuff
1197
1198         -- Check that if the class has generic methods, then the
1199         -- class has only one parameter.  We can't do generic
1200         -- multi-parameter type classes!
1201         ; checkTc (unary || no_generics) (genericMultiParamErr cls)
1202         }
1203   where
1204     (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
1205     unary       = isSingleton tyvars
1206     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
1207
1208     check_op constrained_class_methods (sel_id, dm) 
1209       = addErrCtxt (classOpCtxt sel_id tau) $ do
1210         { checkValidTheta SigmaCtxt (tail theta)
1211                 -- The 'tail' removes the initial (C a) from the
1212                 -- class itself, leaving just the method type
1213
1214         ; traceTc "class op type" (ppr op_ty <+> ppr tau)
1215         ; checkValidType (FunSigCtxt op_name) tau
1216
1217                 -- Check that the type mentions at least one of
1218                 -- the class type variables...or at least one reachable
1219                 -- from one of the class variables.  Example: tc223
1220                 --   class Error e => Game b mv e | b -> mv e where
1221                 --      newBoard :: MonadState b m => m ()
1222                 -- Here, MonadState has a fundep m->b, so newBoard is fine
1223         ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
1224         ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
1225                   (noClassTyVarErr cls sel_id)
1226
1227                 -- Check that for a generic method, the type of 
1228                 -- the method is sufficiently simple
1229         ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
1230                   (badGenericMethodType op_name op_ty)
1231         }
1232         where
1233           op_name = idName sel_id
1234           op_ty   = idType sel_id
1235           (_,theta1,tau1) = tcSplitSigmaTy op_ty
1236           (_,theta2,tau2)  = tcSplitSigmaTy tau1
1237           (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
1238                       | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
1239                 -- Ugh!  The function might have a type like
1240                 --      op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
1241                 -- With -XConstrainedClassMethods, we want to allow this, even though the inner 
1242                 -- forall has an (Eq a) constraint.  Whereas in general, each constraint 
1243                 -- in the context of a for-all must mention at least one quantified
1244                 -- type variable.  What a mess!
1245 \end{code}
1246
1247
1248 %************************************************************************
1249 %*                                                                      *
1250                 Building record selectors
1251 %*                                                                      *
1252 %************************************************************************
1253
1254 \begin{code}
1255 mkDefaultMethodIds :: [TyThing] -> [Id]
1256 -- See Note [Default method Ids and Template Haskell]
1257 mkDefaultMethodIds things
1258   = [ mkDefaultMethodId sel_id dm_name
1259     | AClass cls <- things
1260     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
1261 \end{code}
1262
1263 Note [Default method Ids and Template Haskell]
1264 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1265 Consider this (Trac #4169):
1266    class Numeric a where
1267      fromIntegerNum :: a
1268      fromIntegerNum = ...
1269
1270    ast :: Q [Dec]
1271    ast = [d| instance Numeric Int |]
1272
1273 When we typecheck 'ast' we have done the first pass over the class decl
1274 (in tcTyClDecls), but we have not yet typechecked the default-method
1275 declarations (becuase they can mention value declarations).  So we 
1276 must bring the default method Ids into scope first (so they can be seen
1277 when typechecking the [d| .. |] quote, and typecheck them later.
1278
1279 \begin{code}
1280 mkRecSelBinds :: [TyThing] -> HsValBinds Name
1281 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
1282 --    This makes life easier, because the later type checking will add
1283 --    all necessary type abstractions and applications
1284 mkRecSelBinds ty_things
1285   = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
1286   where
1287     (sigs, binds) = unzip rec_sels
1288     rec_sels = map mkRecSelBind [ (tc,fld) 
1289                                 | ATyCon tc <- ty_things 
1290                                 , fld <- tyConFields tc ]
1291
1292 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
1293 mkRecSelBind (tycon, sel_name)
1294   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
1295   where
1296     loc         = getSrcSpan tycon    
1297     sel_id      = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
1298     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
1299
1300     -- Find a representative constructor, con1
1301     all_cons     = tyConDataCons tycon 
1302     cons_w_field = [ con | con <- all_cons
1303                    , sel_name `elem` dataConFieldLabels con ] 
1304     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
1305
1306     -- Selector type; Note [Polymorphic selectors]
1307     field_ty   = dataConFieldType con1 sel_name
1308     data_ty    = dataConOrigResTy con1
1309     data_tvs   = tyVarsOfType data_ty
1310     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)  
1311     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
1312     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
1313            | otherwise  = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ 
1314                           mkPhiTy (dataConStupidTheta con1) $   -- Urgh!
1315                           mkPhiTy field_theta               $   -- Urgh!
1316                           mkFunTy data_ty field_tau
1317
1318     -- Make the binding: sel (C2 { fld = x }) = x
1319     --                   sel (C7 { fld = x }) = x
1320     --    where cons_w_field = [C2,C7]
1321     sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
1322              | otherwise  = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
1323     mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] 
1324                                  (L loc (HsVar field_var))
1325     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
1326     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
1327     rec_field  = HsRecField { hsRecFieldId = sel_lname
1328                             , hsRecFieldArg = nlVarPat field_var
1329                             , hsRecPun = False }
1330     sel_lname = L loc sel_name
1331     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
1332
1333     -- Add catch-all default case unless the case is exhaustive
1334     -- We do this explicitly so that we get a nice error message that
1335     -- mentions this particular record selector
1336     deflt | not (any is_unused all_cons) = []
1337           | otherwise = [mkSimpleMatch [nlWildPat] 
1338                             (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
1339                                      (nlHsLit msg_lit))]
1340
1341         -- Do not add a default case unless there are unmatched
1342         -- constructors.  We must take account of GADTs, else we
1343         -- get overlap warning messages from the pattern-match checker
1344     is_unused con = not (con `elem` cons_w_field 
1345                          || dataConCannotMatch inst_tys con)
1346     inst_tys = tyConAppArgs data_ty
1347
1348     unit_rhs = mkLHsTupleExpr []
1349     msg_lit = HsStringPrim $ mkFastString $ 
1350               occNameString (getOccName sel_name)
1351
1352 ---------------
1353 tyConFields :: TyCon -> [FieldLabel]
1354 tyConFields tc 
1355   | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
1356   | otherwise     = []
1357 \end{code}
1358
1359 Note [Polymorphic selectors]
1360 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1361 When a record has a polymorphic field, we pull the foralls out to the front.
1362    data T = MkT { f :: forall a. [a] -> a }
1363 Then f :: forall a. T -> [a] -> a
1364 NOT  f :: T -> forall a. [a] -> a
1365
1366 This is horrid.  It's only needed in deeply obscure cases, which I hate.
1367 The only case I know is test tc163, which is worth looking at.  It's far
1368 from clear that this test should succeed at all!
1369
1370 Note [Naughty record selectors]
1371 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1372 A "naughty" field is one for which we can't define a record 
1373 selector, because an existential type variable would escape.  For example:
1374         data T = forall a. MkT { x,y::a }
1375 We obviously can't define       
1376         x (MkT v _) = v
1377 Nevertheless we *do* put a RecSelId into the type environment
1378 so that if the user tries to use 'x' as a selector we can bleat
1379 helpfully, rather than saying unhelpfully that 'x' is not in scope.
1380 Hence the sel_naughty flag, to identify record selectors that don't really exist.
1381
1382 In general, a field is "naughty" if its type mentions a type variable that
1383 isn't in the result type of the constructor.  Note that this *allows*
1384 GADT record selectors (Note [GADT record selectors]) whose types may look 
1385 like     sel :: T [a] -> a
1386
1387 For naughty selectors we make a dummy binding 
1388    sel = ()
1389 for naughty selectors, so that the later type-check will add them to the
1390 environment, and they'll be exported.  The function is never called, because
1391 the tyepchecker spots the sel_naughty field.
1392
1393 Note [GADT record selectors]
1394 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1395 For GADTs, we require that all constructors with a common field 'f' have the same
1396 result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
1397 E.g. 
1398         data T where
1399           T1 { f :: Maybe a } :: T [a]
1400           T2 { f :: Maybe a, y :: b  } :: T [a]
1401
1402 and now the selector takes that result type as its argument:
1403    f :: forall a. T [a] -> Maybe a
1404
1405 Details: the "real" types of T1,T2 are:
1406    T1 :: forall r a.   (r~[a]) => a -> T r
1407    T2 :: forall r a b. (r~[a]) => a -> b -> T r
1408
1409 So the selector loooks like this:
1410    f :: forall a. T [a] -> Maybe a
1411    f (a:*) (t:T [a])
1412      = case t of
1413          T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))
1414          T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
1415
1416 Note the forall'd tyvars of the selector are just the free tyvars
1417 of the result type; there may be other tyvars in the constructor's
1418 type (e.g. 'b' in T2).
1419
1420 Note the need for casts in the result!
1421
1422 Note [Selector running example]
1423 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1424 It's OK to combine GADTs and type families.  Here's a running example:
1425
1426         data instance T [a] where 
1427           T1 { fld :: b } :: T [Maybe b]
1428
1429 The representation type looks like this
1430         data :R7T a where
1431           T1 { fld :: b } :: :R7T (Maybe b)
1432
1433 and there's coercion from the family type to the representation type
1434         :CoR7T a :: T [a] ~ :R7T a
1435
1436 The selector we want for fld looks like this:
1437
1438         fld :: forall b. T [Maybe b] -> b
1439         fld = /\b. \(d::T [Maybe b]).
1440               case d `cast` :CoR7T (Maybe b) of 
1441                 T1 (x::b) -> x
1442
1443 The scrutinee of the case has type :R7T (Maybe b), which can be
1444 gotten by appying the eq_spec to the univ_tvs of the data con.
1445
1446 %************************************************************************
1447 %*                                                                      *
1448                 Error messages
1449 %*                                                                      *
1450 %************************************************************************
1451
1452 \begin{code}
1453 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1454 resultTypeMisMatch field_name con1 con2
1455   = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, 
1456                 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
1457           nest 2 $ ptext (sLit "but have different result types")]
1458
1459 fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1460 fieldTypeMisMatch field_name con1 con2
1461   = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, 
1462          ptext (sLit "give different types for field"), quotes (ppr field_name)]
1463
1464 dataConCtxt :: Outputable a => a -> SDoc
1465 dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
1466
1467 classOpCtxt :: Var -> Type -> SDoc
1468 classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
1469                               nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
1470
1471 nullaryClassErr :: Class -> SDoc
1472 nullaryClassErr cls
1473   = ptext (sLit "No parameters for class")  <+> quotes (ppr cls)
1474
1475 classArityErr :: Class -> SDoc
1476 classArityErr cls
1477   = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls),
1478           parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
1479
1480 classFunDepsErr :: Class -> SDoc
1481 classFunDepsErr cls
1482   = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
1483           parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))]
1484
1485 noClassTyVarErr :: Class -> Var -> SDoc
1486 noClassTyVarErr clas op
1487   = sep [ptext (sLit "The class method") <+> quotes (ppr op),
1488          ptext (sLit "mentions none of the type variables of the class") <+> 
1489                 ppr clas <+> hsep (map ppr (classTyVars clas))]
1490
1491 genericMultiParamErr :: Class -> SDoc
1492 genericMultiParamErr clas
1493   = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> 
1494     ptext (sLit "cannot have generic methods")
1495
1496 badGenericMethodType :: Name -> Kind -> SDoc
1497 badGenericMethodType op op_ty
1498   = hang (ptext (sLit "Generic method type is too complex"))
1499        2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
1500                 ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
1501
1502 recSynErr :: [LTyClDecl Name] -> TcRn ()
1503 recSynErr syn_decls
1504   = setSrcSpan (getLoc (head sorted_decls)) $
1505     addErr (sep [ptext (sLit "Cycle in type synonym declarations:"),
1506                  nest 2 (vcat (map ppr_decl sorted_decls))])
1507   where
1508     sorted_decls = sortLocated syn_decls
1509     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
1510
1511 recClsErr :: [Located (TyClDecl Name)] -> TcRn ()
1512 recClsErr cls_decls
1513   = setSrcSpan (getLoc (head sorted_decls)) $
1514     addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"),
1515                  nest 2 (vcat (map ppr_decl sorted_decls))])
1516   where
1517     sorted_decls = sortLocated cls_decls
1518     ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
1519
1520 sortLocated :: [Located a] -> [Located a]
1521 sortLocated things = sortLe le things
1522   where
1523     le (L l1 _) (L l2 _) = l1 <= l2
1524
1525 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
1526 badDataConTyCon data_con res_ty_tmpl actual_res_ty
1527   = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
1528                 ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
1529        2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
1530
1531 badGadtDecl :: Name -> SDoc
1532 badGadtDecl tc_name
1533   = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
1534          , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
1535
1536 badExistential :: Located Name -> SDoc
1537 badExistential con_name
1538   = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
1539                 ptext (sLit "has existential type variables, or a context"))
1540        2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
1541
1542 badStupidTheta :: Name -> SDoc
1543 badStupidTheta tc_name
1544   = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
1545
1546 newtypeConError :: Name -> Int -> SDoc
1547 newtypeConError tycon n
1548   = sep [ptext (sLit "A newtype must have exactly one constructor,"),
1549          nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ]
1550
1551 newtypeExError :: DataCon -> SDoc
1552 newtypeExError con
1553   = sep [ptext (sLit "A newtype constructor cannot have an existential context,"),
1554          nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1555
1556 newtypeStrictError :: DataCon -> SDoc
1557 newtypeStrictError con
1558   = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"),
1559          nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1560
1561 newtypePredError :: DataCon -> SDoc
1562 newtypePredError con
1563   = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"),
1564          nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")]
1565
1566 newtypeFieldErr :: DataCon -> Int -> SDoc
1567 newtypeFieldErr con_name n_flds
1568   = sep [ptext (sLit "The constructor of a newtype must have exactly one field"), 
1569          nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds]
1570
1571 badSigTyDecl :: Name -> SDoc
1572 badSigTyDecl tc_name
1573   = vcat [ ptext (sLit "Illegal kind signature") <+>
1574            quotes (ppr tc_name)
1575          , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
1576
1577 badFamInstDecl :: Outputable a => a -> SDoc
1578 badFamInstDecl tc_name
1579   = vcat [ ptext (sLit "Illegal family instance for") <+>
1580            quotes (ppr tc_name)
1581          , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1582
1583 tooManyParmsErr :: Located Name -> SDoc
1584 tooManyParmsErr tc_name
1585   = ptext (sLit "Family instance has too many parameters:") <+> 
1586     quotes (ppr tc_name)
1587
1588 tooFewParmsErr :: Arity -> SDoc
1589 tooFewParmsErr arity
1590   = ptext (sLit "Family instance has too few parameters; expected") <+> 
1591     ppr arity
1592
1593 wrongNumberOfParmsErr :: Arity -> SDoc
1594 wrongNumberOfParmsErr exp_arity
1595   = ptext (sLit "Number of parameters must match family declaration; expected")
1596     <+> ppr exp_arity
1597
1598 badBootFamInstDeclErr :: SDoc
1599 badBootFamInstDeclErr
1600   = ptext (sLit "Illegal family instance in hs-boot file")
1601
1602 notFamily :: TyCon -> SDoc
1603 notFamily tycon
1604   = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1605          , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1606   
1607 wrongKindOfFamily :: TyCon -> SDoc
1608 wrongKindOfFamily family
1609   = ptext (sLit "Wrong category of family instance; declaration was for a")
1610     <+> kindOfFamily
1611   where
1612     kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
1613                  | isAlgTyCon family = ptext (sLit "data type")
1614                  | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
1615
1616 emptyConDeclsErr :: Name -> SDoc
1617 emptyConDeclsErr tycon
1618   = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
1619          nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")]
1620 \end{code}