TcTyClsDecls.lhs 53.2 KB
Newer Older
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 9

\begin{code}
module TcTyClsDecls (
10
	tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
11
        checkValidTyCon, dataDeclChecks
12 13
    ) where

14
#include "HsVersions.h"
15

16 17 18
import HsSyn
import HscTypes
import BuildTyCl
19
import TcUnify
20
import TcRnMonad
21 22 23 24 25 26
import TcEnv
import TcTyDecls
import TcClassDcl
import TcHsType
import TcMType
import TcType
27
import TysWiredIn	( unitTy )
28 29 30 31
import Type
import Class
import TyCon
import DataCon
32
import Id
33
import MkCore		( rEC_SEL_ERROR_ID )
34
import IdInfo
35 36 37
import Var
import VarSet
import Name
38
import NameEnv
sof's avatar
sof committed
39
import Outputable
40 41 42 43 44 45 46
import Maybes
import Unify
import Util
import SrcLoc
import ListSetOps
import Digraph
import DynFlags
47
import FastString
48 49
import Unique		( mkBuiltinUnique )
import BasicTypes
50

51
import Bag
Ian Lynagh's avatar
Ian Lynagh committed
52
import Control.Monad
53
import Data.List
54 55
\end{code}

56 57 58 59 60 61 62

%************************************************************************
%*									*
\subsection{Type checking for type and class declarations}
%*									*
%************************************************************************

63
\begin{code}
64

65 66
tcTyAndClassDecls :: ModDetails 
                   -> [[LTyClDecl Name]]     -- Mutually-recursive groups in dependency order
67 68
   	           -> TcM (TcGblEnv,   	     -- Input env extended by types and classes 
					     -- and their implicit Ids,DataCons
69
		           HsValBinds Name)  -- Renamed bindings for record selectors
70 71
-- Fails if there are any errors

72
tcTyAndClassDecls boot_details decls_s
73 74
  = checkNoErrs $ 	-- The code recovers internally, but if anything gave rise to
			-- an error we'd better stop now, to avoid a cascade
75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
    do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
     		  -- Remove family instance decls altogether
		  -- They are dealt with by TcInstDcls
	      
       ; tyclss <- fixM $ \ rec_tyclss ->
              tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
	      	-- We must populate the environment with the loop-tied
	      	-- T's right away (even before kind checking), because 
                -- the kind checker may "fault in" some type constructors 
	      	-- that recursively mention T

              do {    -- Kind-check in dependency order
                      -- See Note [Kind checking for type and class decls]
                   kc_decls <- kcTyClDecls tyclds_s

                      -- And now build the TyCons/Classes
                ; let rec_flags = calcRecFlags boot_details rec_tyclss
92
                ; concatMapM (tcTyClDecl rec_flags) kc_decls }
93

Simon Peyton Jones's avatar
Simon Peyton Jones committed
94 95
       ; traceTc "tcTyAndCl3" (ppr tyclss)

96 97 98 99 100
       ; tcExtendGlobalEnv tyclss $ do
       {  -- Perform the validity check
          -- We can do this now because we are done with the recursive knot
          traceTc "ready for validity check" empty
	; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
101
 	; traceTc "done" empty
102

103
	-- Add the implicit things;
104
	-- we want them in the environment because
105
	-- they may be mentioned in interface files
106 107 108
	-- NB: All associated types and their implicit things will be added a
	--     second time here.  This doesn't matter as the definitions are
	--     the same.
109
	; let {	implicit_things = concatMap implicitTyThings tyclss
110
	      ; rec_sel_binds   = mkRecSelBinds [tc | ATyCon tc <- tyclss]
111 112
              ; dm_ids          = mkDefaultMethodIds tyclss }

113 114 115 116
  	; env <- tcExtendGlobalEnv implicit_things $
                 tcExtendGlobalValEnv dm_ids $
                 getGblEnv
        ; return (env, rec_sel_binds) } }
117 118 119 120 121 122 123 124 125 126
                    
zipRecTyClss :: [[LTyClDecl Name]]
             -> [TyThing]           -- Knot-tied
             -> [(Name,TyThing)]
-- Build a name-TyThing mapping for the things bound by decls
-- being careful not to look at the [TyThing]
-- The TyThings in the result list must have a visible ATyCon/AClass,
-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
zipRecTyClss decls_s rec_things
  = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
127
  where
128 129 130 131 132 133 134 135 136 137 138
    rec_type_env :: TypeEnv
    rec_type_env = mkTypeEnv rec_things

    get :: TyClDecl Name -> (Name, TyThing)
    get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
      where
        Just (AClass cl) = lookupTypeEnv rec_type_env name
    get decl = (name, ATyCon tc)
      where
        name = tcdName decl
        Just (ATyCon tc) = lookupTypeEnv rec_type_env name
139
\end{code}
140 141


142 143
%************************************************************************
%*									*
144
		Kind checking
145 146
%*									*
%************************************************************************
147

148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
Note [Kind checking for type and class decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Kind checking is done thus:

   1. Make up a kind variable for each parameter of the *data* type, 
      and class, decls, and extend the kind environment (which is in
      the TcLclEnv)

   2. Dependency-analyse the type *synonyms* (which must be non-recursive),
      and kind-check them in dependency order.  Extend the kind envt.

   3. Kind check the data type and class decls

Synonyms are treated differently to data type and classes,
because a type synonym can be an unboxed type
	type Foo = Int#
and a kind variable can't unify with UnboxedTypeKind
So we infer their kinds in dependency order

167 168
We need to kind check all types in the mutually recursive group
before we know the kind of the type variables.  For example:
169 170 171 172 173 174 175 176 177 178 179

class C a where
   op :: D b => a -> b -> b

class D c where
   bop :: (Monad c) => ...

Here, the kind of the locally-polymorphic type variable "b"
depends on *all the uses of class D*.  For example, the use of
Monad c in bop's type signature means that D must have kind Type->Type.

180 181 182 183 184 185 186 187
However type synonyms work differently.  They can have kinds which don't
just involve (->) and *:
	type R = Int#		-- Kind #
	type S a = Array# a	-- Kind * -> #
	type T a b = (# a,b #)	-- Kind * -> * -> (# a,b #)
So we must infer their kinds from their right-hand sides *first* and then
use them, whereas for the mutually recursive data types D we bring into
scope kind bindings D -> k, where k is a kind variable, and do inference.
188

189
Type families
190 191 192 193
~~~~~~~~~~~~~
This treatment of type synonyms only applies to Haskell 98-style synonyms.
General type functions can be recursive, and hence, appear in `alg_decls'.

194
The kind of a type family is solely determinded by its kind signature;
195 196
hence, only kind signatures participate in the construction of the initial
kind environment (as constructed by `getInitialKind').  In fact, we ignore
197 198
instances of families altogether in the following.  However, we need to
include the kinds of associated families into the construction of the
199 200
initial kind environment.  (This is handled by `allDecls').

201

202
\begin{code}
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
kcTyClDecls []                = return []
kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
                                   ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
                                   ; return (kc_decls1 ++ kc_decls2) }

kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
kcTyClDecls1 decls
  = do	{       -- Omit instances of type families; they are handled together
		-- with the *heads* of class instances
        ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
              alg_at_decls           = flattenATs alg_decls

	; mod <- getModule
	; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))

        	-- First check for cyclic classes
	; checkClassCycleErrs alg_decls

	   -- Kind checking; see Note [Kind checking for type and class decls]
	; alg_kinds <- mapM getInitialKind alg_at_decls
	; tcExtendKindEnv alg_kinds $  do

        { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
        ; setLclEnv tcl_env $  do
        { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
                
	     -- Kind checking done for this group, so zonk the kind variables
	     -- See Note [Kind checking for type and class decls]
        ; mapM_ (zonkTcKindToKind . snd) alg_kinds

	; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }

flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
flattenATs decls = concatMap flatten decls
238
  where
239 240
    flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
    flatten decl				  = [decl]
241

242
getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
243 244
-- Only for data type, class, and indexed type declarations
-- Get as much info as possible from the data, class, or indexed type decl,
245
-- so as to maximise usefulness of error messages
246
getInitialKind (L _ decl)
247 248 249 250
  = do 	{ arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
	; res_kind  <- mk_res_kind decl
	; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
  where
251
    mk_arg_kind (UserTyVar _ _)      = newKindVar
252 253
    mk_arg_kind (KindedTyVar _ kind) = return kind

254 255 256
    mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
    mk_res_kind (TyData   { tcdKindSig = Just kind }) = return kind
	-- On GADT-style declarations we allow a kind signature
257
	--	data T :: *->* where { ... }
Ian Lynagh's avatar
Ian Lynagh committed
258
    mk_res_kind _ = return liftedTypeKind
259 260 261 262 263


----------------
kcSynDecls :: [SCC (LTyClDecl Name)] 
	   -> TcM ([LTyClDecl Name], 	-- Kind-annotated decls
264
		   TcLclEnv)	-- Kind bindings
265
kcSynDecls []
266
  = do { tcl_env <- getLclEnv; return ([], tcl_env) }
267
kcSynDecls (group : groups)
268 269 270
  = do	{ (decl,  nk)      <- kcSynDecl group
	; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
	; return (decl:decls, tcl_env) }
271 272 273 274 275
			
----------------
kcSynDecl :: SCC (LTyClDecl Name) 
	   -> TcM (LTyClDecl Name, 	-- Kind-annotated decls
		   (Name,TcKind))	-- Kind bindings
Ian Lynagh's avatar
Ian Lynagh committed
276
kcSynDecl (AcyclicSCC (L loc decl))
277 278
  = tcAddDeclCtxt decl	$
    kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
279
    do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
280
			<+> brackets (ppr k_tvs))
281
       ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
282
       ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
283
       ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
284 285 286 287 288 289
       ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
		 (unLoc (tcdLName decl), tc_kind)) })

kcSynDecl (CyclicSCC decls)
  = do { recSynErr decls; failM }	-- Fail here to avoid error cascade
					-- of out-of-scope tycons
290

291 292 293
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
	-- Not used for type synonyms (see kcSynDecl)
294

295
kcTyClDecl decl@(TyData {})
296
  = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance
297 298
    kcTyClDeclBody decl	$
      kcDataDecl decl
299

300 301
kcTyClDecl decl@(TyFamily {})
  = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl      
302

303
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
304
  = kcTyClDeclBody decl	$ \ tvs' ->
Ian Lynagh's avatar
Ian Lynagh committed
305
    do	{ ctxt' <- kcHsContext ctxt	
306 307
	; ats'  <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
	; sigs' <- mapM (wrapLocM kc_sig) sigs
308 309
	; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
		        tcdATs = ats'}) }
310
  where
311 312
    kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
				   ; return (TypeSig nm op_ty') }
313 314
    kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
				      ; return (GenericSig nm op_ty') }
315 316
    kc_sig other_sig	      = return other_sig

317
kcTyClDecl decl@(ForeignType {})
318 319
  = return decl

Ian Lynagh's avatar
Ian Lynagh committed
320 321
kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"

322
kcTyClDeclBody :: TyClDecl Name
323
	       -> ([LHsTyVarBndr Name] -> TcM a)
324
	       -> TcM a
325 326 327 328
-- getInitialKind has made a suitably-shaped kind for the type or class
-- Unpack it, and attribute those kinds to the type variables
-- Extend the env with bindings for the tyvars, taken from
-- the kind of the tycon/class.  Give it to the thing inside, and 
329
-- check the result kind matches
330
kcTyClDeclBody decl thing_inside
331
  = tcAddDeclCtxt decl		$
332
    do 	{ tc_ty_thing <- tcLookupLocated (tcdLName decl)
Ian Lynagh's avatar
Ian Lynagh committed
333
	; let tc_kind	 = case tc_ty_thing of
334 335
                             AThing k -> k
                             _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
336 337 338
	      (kinds, _) = splitKindFunTys tc_kind
	      hs_tvs 	 = tcdTyVars decl
	      kinded_tvs = ASSERT( length kinds >= length hs_tvs )
339 340 341 342 343
			   zipWith add_kind hs_tvs kinds
	; tcExtendKindEnvTvs kinded_tvs thing_inside }
  where
    add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
    add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
344 345 346 347 348 349 350 351 352

-- Kind check a data declaration, assuming that we already extended the
-- kind environment with the type variables of the left-hand side (these
-- kinded type variables are also passed as the second parameter).
--
kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
	   tvs
  = do	{ ctxt' <- kcHsContext ctxt	
353
	; cons' <- mapM (wrapLocM kc_con_decl) cons
354 355
	; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
  where
356
    -- doc comments are typechecked to Nothing here
357 358
    kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
                                  , con_cxt = ex_ctxt, con_details = details, con_res = res })
359 360 361 362 363 364 365
      = addErrCtxt (dataConCtxt name)	$ 
        kcHsTyVars ex_tvs $ \ex_tvs' -> do
        do { ex_ctxt' <- kcHsContext ex_ctxt
           ; details' <- kc_con_details details 
           ; res'     <- case res of
                ResTyH98 -> return ResTyH98
                ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
366 367
           ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
                              , con_details = details', con_res = res' }) }
368 369

    kc_con_details (PrefixCon btys) 
370
	= do { btys' <- mapM kc_larg_ty btys 
371
             ; return (PrefixCon btys') }
372
    kc_con_details (InfixCon bty1 bty2) 
373 374 375
	= do { bty1' <- kc_larg_ty bty1
             ; bty2' <- kc_larg_ty bty2
             ; return (InfixCon bty1' bty2') }
376
    kc_con_details (RecCon fields) 
377
	= do { fields' <- mapM kc_field fields
378
             ; return (RecCon fields') }
379

380 381
    kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
					   ; return (ConDeclField fld bty' d) }
382 383 384 385 386 387 388

    kc_larg_ty bty = case new_or_data of
			DataType -> kcHsSigType bty
			NewType  -> kcHsLiftedSigType bty
	-- Can't allow an unlifted type for newtypes, because we're effectively
	-- going to remove the constructor while coercing it to a lifted type.
	-- And newtypes can't be bang'd
Ian Lynagh's avatar
Ian Lynagh committed
389
kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
390 391 392 393 394 395 396 397 398 399 400 401 402

-- Kind check a family declaration or type family default declaration.
--
kcFamilyDecl :: [LHsTyVarBndr Name]  -- tyvars of enclosing class decl if any
             -> TyClDecl Name -> TcM (TyClDecl Name)
kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
  = kcTyClDeclBody decl $ \tvs' ->
    do { mapM_ unifyClassParmKinds tvs'
       ; return (decl {tcdTyVars = tvs', 
		       tcdKind = kind `mplus` Just liftedTypeKind})
		       -- default result kind is '*'
       }
  where
403 404 405 406 407 408 409
    unifyClassParmKinds (L _ tv) 
      | (n,k) <- hsTyVarNameKind tv
      , Just classParmKind <- lookup n classTyKinds 
      = unifyKind k classParmKind
      | otherwise = return ()
    classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]

Ian Lynagh's avatar
Ian Lynagh committed
410
kcFamilyDecl _ (TySynonym {})              -- type family defaults
411
  = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
Ian Lynagh's avatar
Ian Lynagh committed
412
kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
413 414 415 416 417
\end{code}


%************************************************************************
%*									*
418
\subsection{Type checking}
419 420
%*									*
%************************************************************************
421 422

\begin{code}
423
tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
424

425 426
tcTyClDecl calc_isrec (L loc decl)
  = setSrcSpan loc $ tcAddDeclCtxt decl $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
427
    traceTc "tcTyAndCl-x" (ppr decl) >>
428
    tcTyClDecl1 NoParentTyCon calc_isrec decl
429

430
  -- "type family" declarations
431 432
tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _calc_isrec 
433
  (TyFamily {tcdFlavour = TypeFamily, 
434 435
	     tcdLName = L _ tc_name, tcdTyVars = tvs,
             tcdKind = Just kind}) -- NB: kind at latest added during kind checking
436
  = tcTyVarBndrs tvs  $ \ tvs' -> do 
437
  { traceTc "type family:" (ppr tc_name) 
438
  ; checkFamFlag tc_name
439
  ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
440
  ; return [ATyCon tycon]
441
  }
442

443
  -- "data family" declaration
444
tcTyClDecl1 parent _calc_isrec 
445
  (TyFamily {tcdFlavour = DataFamily, 
446
	     tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
447
  = tcTyVarBndrs tvs  $ \ tvs' -> do 
448
  { traceTc "data family:" (ppr tc_name) 
449
  ; checkFamFlag tc_name
450
  ; extra_tvs <- tcDataKindSig mb_kind
451 452
  ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
  ; tycon <- buildAlgTyCon tc_name final_tvs [] 
453
               DataFamilyTyCon Recursive True 
454
               parent Nothing
455
  ; return [ATyCon tycon]
456 457
  }

458
  -- "type" synonym declaration
459 460 461 462 463 464 465 466 467 468
tcTyClDecl1 _parent _calc_isrec
  (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
  = ASSERT( isNoParent _parent )
    tcTyVarBndrs tvs		$ \ tvs' -> do 
    { traceTc "tcd1" (ppr tc_name) 
    ; rhs_ty' <- tcHsKindedType rhs_ty
    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') 
      	       		     (typeKind rhs_ty') NoParentTyCon  Nothing
    ; return [ATyCon tycon] }

469
  -- "newtype" and "data"
470
  -- NB: not used for newtype/data instances (whether associated or not)
471
tcTyClDecl1 _parent calc_isrec
472
  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
473
	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
474 475
  = ASSERT( isNoParent _parent )
    tcTyVarBndrs tvs	$ \ tvs' -> do 
476 477
  { extra_tvs <- tcDataKindSig mb_ksig
  ; let final_tvs = tvs' ++ extra_tvs
478
  ; stupid_theta <- tcHsKindedContext ctxt
479 480 481
  ; kind_signatures <- xoptM Opt_KindSignatures
  ; existential_ok <- xoptM Opt_ExistentialQuantification
  ; gadt_ok      <- xoptM Opt_GADTs
482
  ; is_boot	 <- tcIsHsBoot	-- Are we compiling an hs-boot file?
483
  ; let ex_ok = existential_ok || gadt_ok	-- Data cons can have existential context
484

485
	-- Check that we don't use kind signatures without Glasgow extensions
Ian Lynagh's avatar
Ian Lynagh committed
486
  ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
487

488
  ; dataDeclChecks tc_name new_or_data stupid_theta cons
489

490
  ; tycon <- fixM (\ tycon -> do 
491
	{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
492
	; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons
493 494 495 496 497
	; tc_rhs <-
	    if null cons && is_boot 	-- In a hs-boot file, empty cons means
	    then return AbstractTyCon	-- "don't know"; hence Abstract
	    else case new_or_data of
		   DataType -> return (mkDataTyConRhs data_cons)
498 499
		   NewType  -> ASSERT( not (null data_cons) )
                               mkNewTyConRhs tc_name tycon (head data_cons)
500
	; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
501
	    (not h98_syntax) NoParentTyCon Nothing
502
	})
503
  ; return [ATyCon tycon]
504
  }
505
  where
506
    is_rec   = calc_isrec tc_name
507
    h98_syntax = consUseH98Syntax cons
508

509
tcTyClDecl1 _parent calc_isrec 
510
  (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
511
	      tcdCtxt = ctxt, tcdMeths = meths,
512
	      tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
513 514
  = ASSERT( isNoParent _parent )
    tcTyVarBndrs tvs		$ \ tvs' -> do 
515
  { ctxt' <- tcHsKindedContext ctxt
516
  ; fds' <- mapM (addLocM tc_fundep) fundeps
517
  ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
518 519
  ; clas <- fixM $ \ clas -> do
	    { let 	-- This little knot is just so we can get
520
			-- hold of the name of the class TyCon, which we
521
			-- need to look up its recursiveness
522 523
		    tycon_name = tyConName (classTyCon clas)
		    tc_isrec = calc_isrec tycon_name
524 525 526 527 528 529
	    ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
            -- NB: 'ats' only contains "type family" and "data family"
            --     declarations as well as type family defaults
            ; buildClass False {- Must include unfoldings for selectors -}
			 class_name tvs' ctxt' fds' (concat atss')
			 sig_stuff tc_isrec }
530 531 532 533 534 535 536 537 538 539 540 541

  ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
                     | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
                     , let gen_dm_tau = expectJust "tcTyClDecl1" $
                                        lookupNameEnv gen_dm_env (idName sel_id)
		     , let gen_dm_ty = mkSigmaTy tvs' 
                                                 [mkClassPred clas (mkTyVarTys tvs')] 
                                                 gen_dm_tau
                     ]
        class_ats = map ATyCon (classATs clas)

  ; return (AClass clas : gen_dm_ids ++ class_ats )
542 543 544
      -- NB: Order is important due to the call to `mkGlobalThings' when
      --     tying the the type and class declaration type checking knot.
  }
545
  where
546 547
    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
				; tvs2' <- mapM tcLookupTyVar tvs2 ;
548
				; return (tvs1', tvs2') }
549

550
tcTyClDecl1 _ _
551
  (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
552
  = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
553

554
tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
Ian Lynagh's avatar
Ian Lynagh committed
555

556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578
dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
dataDeclChecks tc_name new_or_data stupid_theta cons
  = do {   -- Check that we don't use GADT syntax in H98 world
         gadtSyntax_ok <- xoptM Opt_GADTSyntax
       ; let h98_syntax = consUseH98Syntax cons
       ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)

	   -- Check that the stupid theta is empty for a GADT-style declaration
       ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)

	-- Check that a newtype has exactly one constructor
	-- Do this before checking for empty data decls, so that
	-- we don't suggest -XEmptyDataDecls for newtypes
      ; checkTc (new_or_data == DataType || isSingleton cons) 
	        (newtypeConError tc_name (length cons))

 	-- Check that there's at least one condecl,
	-- or else we're reading an hs-boot file, or -XEmptyDataDecls
      ; empty_data_decls <- xoptM Opt_EmptyDataDecls
      ; is_boot <- tcIsHsBoot	-- Are we compiling an hs-boot file?
      ; checkTc (not (null cons) || empty_data_decls || is_boot)
                (emptyConDeclsErr tc_name) }
    
579
-----------------------------------
580
tcConDecls :: Bool -> TyCon -> ([TyVar], Type)
581
	   -> [LConDecl Name] -> TcM [DataCon]
582 583
tcConDecls ex_ok rep_tycon res_tmpl cons
  = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons
584

585
tcConDecl :: Bool		-- True <=> -XExistentialQuantificaton or -XGADTs
586 587
	  -> TyCon 		-- Representation tycon
	  -> ([TyVar], Type)	-- Return type template (with its template tyvars)
588 589
	  -> ConDecl Name 
	  -> TcM DataCon
590

591
tcConDecl existential_ok rep_tycon res_tmpl 	-- Data types
Ian Lynagh's avatar
Ian Lynagh committed
592
	  con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
593
                   , con_details = details, con_res = res_ty })
594 595
  = addErrCtxt (dataConCtxt name)	$ 
    tcTyVarBndrs tvs			$ \ tvs' -> do 
596
    { ctxt' <- tcHsKindedContext ctxt
Ian Lynagh's avatar
Ian Lynagh committed
597
    ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
598
	      (badExistential name)
599
    ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
600
    ; let 
601
	tc_datacon is_infix field_lbls btys
602
	  = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys
603
    	       ; buildDataCon (unLoc name) is_infix
604
    		    stricts field_lbls
605
    		    univ_tvs ex_tvs eq_preds ctxt' arg_tys
606
		    res_ty' rep_tycon }
607 608 609
		-- NB:	we put data_tc, the type constructor gotten from the
		--	constructor type signature into the data constructor;
		--	that way checkValidDataCon can complain if it's wrong.
610

611
    ; case details of
612
	PrefixCon btys     -> tc_datacon False [] btys
613 614 615
	InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
	RecCon fields      -> tc_datacon False field_names btys
			   where
616
			      field_names = map (unLoc . cd_fld_name) fields
617
			      btys        = map cd_fld_type fields
618 619
    }

620 621 622 623 624 625 626 627 628 629
-- Example
--   data instance T (b,c) where 
--	TI :: forall e. e -> T (e,e)
--
-- The representation tycon looks like this:
--   data :R7T b c where 
--	TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
-- In this case orig_res_ty = T (e,e)

tcResultType :: ([TyVar], Type)	-- Template for result type; e.g.
630 631 632
				-- data instance T [a] b c = ...  
				--      gives template ([a,b,c], T [a] b c)
	     -> [TyVar] 	-- where MkT :: forall x y z. ...
633 634
	     -> ResType Name
	     -> TcM ([TyVar],	 	-- Universal
635
		     [TyVar],		-- Existential (distinct OccNames from univs)
636
		     [(TyVar,Type)],	-- Equality predicates
637
		     Type)		-- Typechecked return type
638 639 640 641
	-- We don't check that the TyCon given in the ResTy is
	-- the same as the parent tycon, becuase we are in the middle
	-- of a recursive knot; so it's postponed until checkValidDataCon

642 643
tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
  = return (tmpl_tvs, dc_tvs, [], res_ty)
644 645 646 647
	-- In H98 syntax the dc_tvs are the existential ones
	--	data T a b c = forall d e. MkT ...
	-- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs

648 649 650
tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
	-- E.g.  data T [a] b c where
	--	   MkT :: forall x y z. T [(x,y)] z z
651
	-- Then we generate
652 653 654 655 656
	--	Univ tyvars	Eq-spec
	--	    a              a~(x,y)
	--	    b		   b~z
	--	    z		   
	-- Existentials are the leftover type vars: [x,y]
657
	-- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
658 659 660
  = do	{ res_ty' <- tcHsKindedType res_ty
	; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'

Ian Lynagh's avatar
Ian Lynagh committed
661
		-- /Lazily/ figure out the univ_tvs etc
662 663 664 665 666 667 668 669 670
		-- Each univ_tv is either a dc_tv or a tmpl_tv
	      (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
	      choose tmpl (univs, eqs)
		| Just ty <- lookupTyVar subst tmpl 
		= case tcGetTyVar_maybe ty of
		    Just tv | not (tv `elem` univs)
			    -> (tv:univs,   eqs)
		    _other  -> (tmpl:univs, (tmpl,ty):eqs)
		| otherwise = pprPanic "tcResultType" (ppr res_ty)
671
	      ex_tvs = dc_tvs `minusList` univ_tvs
672 673

	; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
674
  where
675
	-- NB: tmpl_tvs and dc_tvs are distinct, but
676 677 678 679
	-- we want them to be *visibly* distinct, both for
	-- interface files and general confusion.  So rename
	-- the tc_tvs, since they are not used yet (no 
	-- consequential renaming needed)
680 681 682
    (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
    init_occ_env       = initTidyOccEnv (map getOccName dc_tvs)
    tidy_one env tv    = (env', setTyVarName tv (tidyNameOcc name occ'))
683 684 685 686
	      where
		 name = tyVarName tv
		 (env', occ') = tidyOccName env (getOccName name) 

687 688 689 690 691
consUseH98Syntax :: [LConDecl a] -> Bool
consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
consUseH98Syntax _                                             = True
		 -- All constructors have same shape

Ian Lynagh's avatar
Ian Lynagh committed
692 693 694 695 696 697 698 699 700 701 702 703 704 705 706
conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
conRepresentibleWithH98Syntax
    (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
        = null tvs && null (unLoc ctxt)
conRepresentibleWithH98Syntax
    (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
        = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
    where -- Each type variable should be used exactly once in the
          -- result type, and the result type must just be the type
          -- constructor applied to type variables
          f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
              = (v2 `elem` vs) && f t1 (delete v2 vs)
          f (HsTyVar _) [] = True
          f _ _ = False

707
-------------------
708 709
tcConArg :: LHsType Name -> TcM (TcType, HsBang)
tcConArg bty
710
  = do  { arg_ty <- tcHsBangType bty
711
        ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty)
712
	; return (arg_ty, strict_mark) }
713 714 715 716

-- We attempt to unbox/unpack a strict field when either:
--   (i)  The field is marked '!!', or
--   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
717 718 719
--
-- We have turned off unboxing of newtypes because coercions make unboxing 
-- and reboxing more complicated
720 721
chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang
chooseBoxingStrategy arg_ty bang
722
  = case bang of
723 724 725 726 727 728 729 730 731 732
	HsNoBang -> return HsNoBang
	HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields
                       ; if unbox_strict then return (can_unbox HsStrict arg_ty)
                                         else return HsStrict }
	HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas
            -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
	    -- See Trac #5252: unpacking means we must not conceal the
	    --                 representation of the argument type
                       ; if omit_prags then return HsStrict
                                       else return (can_unbox HsUnpackFailed arg_ty) }
733 734
	HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
		       	  -- Source code never has shtes
735
  where
736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755
    can_unbox :: HsBang -> TcType -> HsBang
    -- Returns   HsUnpack  if we can unpack arg_ty
    -- 		 fail_bang if we know what arg_ty is but we can't unpack it
    -- 		 HsStrict  if it's abstract, so we don't know whether or not we can unbox it
    can_unbox fail_bang arg_ty 
       = case splitTyConApp_maybe arg_ty of
	    Nothing -> fail_bang

	    Just (arg_tycon, tycon_args) 
              | isAbstractTyCon arg_tycon -> HsStrict	
                      -- See Note [Don't complain about UNPACK on abstract TyCons]
              | not (isRecursiveTyCon arg_tycon) 	-- Note [Recusive unboxing]
	      , isProductTyCon arg_tycon 
	      	    -- We can unbox if the type is a chain of newtypes 
		    -- with a product tycon at the end
              -> if isNewTyCon arg_tycon 
                 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
                 else HsUnpack

              | otherwise -> fail_bang
756 757
\end{code}

758 759 760 761 762 763 764 765 766
Note [Don't complain about UNPACK on abstract TyCons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are going to complain about UnpackFailed, but if we say
   data T = MkT {-# UNPACK #-} !Wobble
and Wobble is a newtype imported from a module that was compiled 
without optimisation, we don't want to complain. Because it might
be fine when optimsation is on.  I think this happens when Haddock
is working over (say) GHC souce files.

767 768 769
Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful not to try to unbox this!
Simon Peyton Jones's avatar
Simon Peyton Jones committed
770 771 772 773 774 775 776 777
	data T = MkT {-# UNPACK #-} !T Int
Reason: consider
  data R = MkR {-# UNPACK #-} !S Int
  data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
of S (plus Int); the rep args of MkS are Int#.  This is obviously no
good for T, because then we'd get an infinite number of arguments.

778 779 780 781
But it's the *argument* type that matters. This is fine:
	data S = MkS S !Int
because Int is non-recursive.

782

783 784
%************************************************************************
%*									*
785
		Validity checking
786 787 788
%*									*
%************************************************************************

789 790 791
Validity checking is done once the mutually-recursive knot has been
tied, so we can look at things freely.

792
\begin{code}
793 794
checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
checkClassCycleErrs tyclss
795
  | null cls_cycles
796 797
  = return ()
  | otherwise
798
  = do	{ mapM_ recClsErr cls_cycles
799 800
	; failM	}	-- Give up now, because later checkValidTyCl
			-- will loop if the synonym is recursive
801
  where
802
    cls_cycles = calcClassCycles tyclss
803

804
checkValidTyCl :: TyClDecl Name -> TcM ()
805 806 807 808
-- We do the validity check over declarations, rather than TyThings
-- only so that we can add a nice context with tcAddDeclCtxt
checkValidTyCl decl
  = tcAddDeclCtxt decl $
809
    do	{ thing <- tcLookupLocatedGlobal (tcdLName decl)
810
	; traceTc "Validity of" (ppr thing)	
811 812
	; case thing of
	    ATyCon tc -> checkValidTyCon tc
813 814
	    AClass cl -> do { checkValidClass cl 
                            ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
815 816
            AnId _    -> return ()  -- Generic default methods are checked
	    	      	 	    -- with their parent class
817
            _         -> panic "checkValidTyCl"
818
	; traceTc "Done validity of" (ppr thing)	
819 820 821
	}

-------------------------
822 823 824 825 826 827
-- For data types declared with record syntax, we require
-- that each constructor that has a field 'f' 
--	(a) has the same result type
--	(b) has the same type for 'f'
-- module alpha conversion of the quantified type variables
-- of the constructor.
828 829 830 831 832 833 834
--
-- Note that we allow existentials to match becuase the
-- fields can never meet. E.g
--	data T where
--	  T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
--	  T2 { f1 :: c, f2 :: c, f3 ::Int } :: T  
-- Here we do not complain about f1,f2 because they are existential
835

836
checkValidTyCon :: TyCon -> TcM ()
837
checkValidTyCon tc 
838
  | isSynTyCon tc 
839
  = case synTyConRhs tc of
840 841
      SynFamilyTyCon {} -> return ()
      SynonymTyCon ty   -> checkValidType syn_ctxt ty
842
  | otherwise
843 844
  = do	-- Check the context on the data decl
    checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
845 846
	
	-- Check arg types of data constructors
847
    mapM_ (checkValidDataCon tc) data_cons
848

849
	-- Check that fields with the same name share a type
850
    mapM_ check_fields groups
851

852
  where
853 854 855
    syn_ctxt  = TySynCtxt name
    name      = tyConName tc
    data_cons = tyConDataCons tc
856

857 858
    groups = equivClasses cmp_fld (concatMap get_fields data_cons)
    cmp_fld (f1,_) (f2,_) = f1 `compare` f2
859
    get_fields con = dataConFieldLabels con `zip` repeat con
860
	-- dataConFieldLabels may return the empty list, which is fine
861

862 863 864 865 866 867 868 869 870 871 872 873 874 875
    -- See Note [GADT record selectors] in MkId.lhs
    -- We must check (a) that the named field has the same 
    --                   type in each constructor
    --               (b) that those constructors have the same result type
    --
    -- However, the constructors may have differently named type variable
    -- and (worse) we don't know how the correspond to each other.  E.g.
    --     C1 :: forall a b. { f :: a, g :: b } -> T a b
    --     C2 :: forall d c. { f :: c, g :: c } -> T c d
    -- 
    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
    -- result type against other candidates' types BOTH WAYS ROUND.
    -- If they magically agrees, take the substitution and
    -- apply them to the latter ones, and see if they match perfectly.
Ian Lynagh's avatar
Ian Lynagh committed
876
    check_fields ((label, con1) : other_fields)
877 878
	-- These fields all have the same name, but are from
	-- different constructors in the data type
879 880
	= recoverM (return ()) $ mapM_ checkOne other_fields
                -- Check that all the fields in the group have the same type
881 882
		-- NB: this check assumes that all the constructors of a given
		-- data type use the same type variables
883
        where
884 885
	(tvs1, _, _, res1) = dataConSig con1
        ts1 = mkVarSet tvs1
886 887 888
        fty1 = dataConFieldType con1 label

        checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
889 890
	    = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
		 ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
891
	    where        
892 893
		(tvs2, _, _, res2) = dataConSig con2
	   	ts2 = mkVarSet tvs2
894
                fty2 = dataConFieldType con2 label
Ian Lynagh's avatar
Ian Lynagh committed
895
    check_fields [] = panic "checkValidTyCon/check_fields []"
896

Ian Lynagh's avatar
Ian Lynagh committed
897 898
checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
                 -> Type -> Type -> Type -> Type -> TcM ()
899 900 901 902
checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
  = do	{ checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
	; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
  where
903
    mb_subst1 = tcMatchTy tvs1 res1 res2
904
    mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
905 906

-------------------------------
907 908
checkValidDataCon :: TyCon -> DataCon -> TcM ()
checkValidDataCon tc con
909 910
  = setSrcSpan (srcLocSpan (getSrcLoc con))	$
    addErrCtxt (dataConCtxt con)		$ 
911
    do	{ traceTc "Validity of data con" (ppr con)
912
        ; let tc_tvs = tyConTyVars tc
913 914 915 916 917 918
	      res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
	      actual_res_ty = dataConOrigResTy con
	; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
				res_ty_tmpl
				actual_res_ty))
		  (badDataConTyCon con res_ty_tmpl actual_res_ty)
919 920 921
	; checkValidMonoType (dataConOrigResTy con)
		-- Disallow MkT :: T (forall a. a->a)
		-- Reason: it's really the argument of an equality constraint
922
	; checkValidType ctxt (dataConUserType con)
923
	; when (isNewTyCon tc) (checkNewDataCon con)
924
        ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
925
    }
926 927
  where
    ctxt = ConArgCtxt (dataConName con) 
928 929 930 931 932
    check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
    check_bang _                   = return ()

    cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
                           , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
933

934 935 936 937 938 939 940 941
-------------------------------
checkNewDataCon :: DataCon -> TcM ()
-- Checks for the data constructor of a newtype
checkNewDataCon con
  = do	{ checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
		-- One argument
	; checkTc (null eq_spec) (newtypePredError con)
		-- Return type is (T a b c)
942
	; checkTc (null ex_tvs && null theta) (newtypeExError con)
943
		-- No existentials
944
	; checkTc (not (any isBanged (dataConStrictMarks con))) 
945
		  (newtypeStrictError con)
946
		-- No strictness
947 948
    }
  where
949
    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
950

951 952 953
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
954 955 956
  = do	{ constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
	; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
	; fundep_classes <- xoptM Opt_FunctionalDependencies
957 958 959

    	-- Check that the class is unary, unless GlaExs
	; checkTc (notNull tyvars) (nullaryClassErr cls)
Ian Lynagh's avatar
Ian Lynagh committed
960
	; checkTc (multi_param_type_classes || unary) (classArityErr cls)
961
	; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
962 963 964 965 966

   	-- Check the super-classes
	; checkValidTheta (ClassSCCtxt (className cls)) theta

	-- Check the class operations
967
	; mapM_ (check_op constrained_class_methods) op_stuff
simonm's avatar