2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
6 TcTyClsDecls: Typecheck type and class declarations
10 tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
13 #include "HsVersions.h"
26 import TysWiredIn ( unitTy )
33 import MkId ( mkDefaultMethodId )
34 import MkCore ( rEC_SEL_ERROR_ID )
48 import Unique ( mkBuiltinUnique )
57 %************************************************************************
59 \subsection{Type checking for type and class declarations}
61 %************************************************************************
65 tcTyAndClassDecls :: ModDetails
66 -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
67 -> TcM (TcGblEnv, -- Input env extended by types and classes
68 -- and their implicit Ids,DataCons
69 HsValBinds Name, -- Renamed bindings for record selectors
70 [Id], -- Default method ids
71 [LTyClDecl Name]) -- Kind-checked declarations
72 -- Fails if there are any errors
74 tcTyAndClassDecls boot_details decls_s
75 = checkNoErrs $ -- The code recovers internally, but if anything gave rise to
76 -- an error we'd better stop now, to avoid a cascade
77 do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
78 -- Remove family instance decls altogether
79 -- They are dealt with by TcInstDcls
81 ; tyclss <- fixM $ \ rec_tyclss ->
82 tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
83 -- We must populate the environment with the loop-tied
84 -- T's right away (even before kind checking), because
85 -- the kind checker may "fault in" some type constructors
86 -- that recursively mention T
88 do { -- Kind-check in dependency order
89 -- See Note [Kind checking for type and class decls]
90 kc_decls <- kcTyClDecls tyclds_s
92 -- And now build the TyCons/Classes
93 ; let rec_flags = calcRecFlags boot_details rec_tyclss
94 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
96 ; tcExtendGlobalEnv tyclss $ do
97 { -- Perform the validity check
98 -- We can do this now because we are done with the recursive knot
99 traceTc "ready for validity check" empty
100 ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
101 ; traceTc "done" empty
103 -- Add the implicit things;
104 -- we want them in the environment because
105 -- they may be mentioned in interface files
106 -- NB: All associated types and their implicit things will be added a
107 -- second time here. This doesn't matter as the definitions are
109 ; let { implicit_things = concatMap implicitTyThings tyclss
110 ; rec_sel_binds = mkRecSelBinds tyclss
111 ; dm_ids = mkDefaultMethodIds tyclss }
113 ; env <- tcExtendGlobalEnv implicit_things getGblEnv
114 -- We need the kind-checked declarations later, so we return them
116 ; kc_decls <- kcTyClDecls tyclds_s
117 ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
119 zipRecTyClss :: [[LTyClDecl Name]]
120 -> [TyThing] -- Knot-tied
122 -- Build a name-TyThing mapping for the things bound by decls
123 -- being careful not to look at the [TyThing]
124 -- The TyThings in the result list must have a visible ATyCon/AClass,
125 -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
126 zipRecTyClss decls_s rec_things
127 = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
129 rec_type_env :: TypeEnv
130 rec_type_env = mkTypeEnv rec_things
132 get :: TyClDecl Name -> (Name, TyThing)
133 get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
135 Just (AClass cl) = lookupTypeEnv rec_type_env name
136 get decl = (name, ATyCon tc)
139 Just (ATyCon tc) = lookupTypeEnv rec_type_env name
143 %************************************************************************
145 Type checking family instances
147 %************************************************************************
149 Family instances are somewhat of a hybrid. They are processed together with
150 class instance heads, but can contain data constructors and hence they share a
151 lot of kinding and type checking code with ordinary algebraic data types (and
155 tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
156 tcFamInstDecl top_lvl (L loc decl)
157 = -- Prime error recovery, set source location
160 do { -- type family instances require -XTypeFamilies
161 -- and can't (currently) be in an hs-boot file
162 ; type_families <- xoptM Opt_TypeFamilies
163 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
164 ; checkTc type_families $ badFamInstDecl (tcdLName decl)
165 ; checkTc (not is_boot) $ badBootFamInstDeclErr
167 -- Perform kind and type checking
168 ; tc <- tcFamInstDecl1 decl
169 ; checkValidTyCon tc -- Remember to check validity;
170 -- no recursion to worry about here
172 -- Check that toplevel type instances are not for associated types.
173 ; when (isTopLevel top_lvl && isAssocFamily tc)
174 (addErr $ assocInClassErr (tcdName decl))
176 ; return (ATyCon tc) }
178 isAssocFamily :: TyCon -> Bool -- Is an assocaited type
180 = case tyConFamInst_maybe tycon of
181 Nothing -> panic "isAssocFamily: no family?!?"
182 Just (fam, _) -> isTyConAssoc fam
184 assocInClassErr :: Name -> SDoc
186 = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
187 ptext (sLit "must be inside a class instance")
191 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
194 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
195 = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
196 do { -- check that the family declaration is for a synonym
197 checkTc (isFamilyTyCon family) (notFamily family)
198 ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
200 ; -- (1) kind check the right-hand side of the type equation
201 ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
202 -- ToDo: the ExpKind could be better
204 -- we need the exact same number of type parameters as the family
206 ; let famArity = tyConArity family
207 ; checkTc (length k_typats == famArity) $
208 wrongNumberOfParmsErr famArity
210 -- (2) type check type equation
211 ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
212 ; t_typats <- mapM tcHsKindedType k_typats
213 ; t_rhs <- tcHsKindedType k_rhs
215 -- (3) check the well-formedness of the instance
216 ; checkValidTypeInst t_typats t_rhs
218 -- (4) construct representation tycon
219 ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
220 ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
222 NoParentTyCon (Just (family, t_typats))
225 -- "newtype instance" and "data instance"
226 tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
228 = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
229 do { -- check that the family declaration is for the right kind
230 checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
231 ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
233 ; -- (1) kind check the data declaration as usual
234 ; k_decl <- kcDataDecl decl k_tvs
235 ; let k_ctxt = tcdCtxt k_decl
236 k_cons = tcdCons k_decl
238 -- result kind must be '*' (otherwise, we have too few patterns)
239 ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
241 -- (2) type check indexed data type declaration
242 ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
243 ; unbox_strict <- doptM Opt_UnboxStrictFields
245 -- kind check the type indexes and the context
246 ; t_typats <- mapM tcHsKindedType k_typats
247 ; stupid_theta <- tcHsKindedContext k_ctxt
250 -- (a) left-hand side contains no type family applications
251 -- (vanilla synonyms are fine, though, and we checked for
253 ; mapM_ checkTyFamFreeness t_typats
255 -- Check that we don't use GADT syntax in H98 world
256 ; gadt_ok <- xoptM Opt_GADTs
257 ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
259 -- (b) a newtype has exactly one constructor
260 ; checkTc (new_or_data == DataType || isSingleton k_cons) $
261 newtypeConError tc_name (length k_cons)
263 -- (4) construct representation tycon
264 ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
265 ; let ex_ok = True -- Existentials ok for type families!
266 ; fixM (\ rep_tycon -> do
267 { let orig_res_ty = mkTyConApp fam_tycon t_typats
268 ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
269 (t_tvs, orig_res_ty) k_cons
272 DataType -> return (mkDataTyConRhs data_cons)
273 NewType -> ASSERT( not (null data_cons) )
274 mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
275 ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
276 False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
277 -- We always assume that indexed types are recursive. Why?
278 -- (1) Due to their open nature, we can never be sure that a
279 -- further instance might not introduce a new recursive
280 -- dependency. (2) They are always valid loop breakers as
281 -- they involve a coercion.
285 h98_syntax = case cons of -- All constructors have same shape
286 L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
289 tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
291 -- Kind checking of indexed types
294 -- Kind check type patterns and kind annotate the embedded type variables.
296 -- * Here we check that a type instance matches its kind signature, but we do
297 -- not check whether there is a pattern for each type index; the latter
298 -- check is only required for type synonym instances.
300 kcIdxTyPats :: TyClDecl Name
301 -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
302 -- ^^kinded tvs ^^kinded ty pats ^^res kind
304 kcIdxTyPats decl thing_inside
305 = kcHsTyVars (tcdTyVars decl) $ \tvs ->
306 do { let tc_name = tcdLName decl
307 ; fam_tycon <- tcLookupLocatedTyCon tc_name
308 ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
309 ; hs_typats = fromJust $ tcdTyPats decl }
311 -- we may not have more parameters than the kind indicates
312 ; checkTc (length kinds >= length hs_typats) $
313 tooManyParmsErr (tcdLName decl)
315 -- type functions can have a higher-kinded result
316 ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
317 ; typats <- zipWithM kcCheckLHsType hs_typats
318 [ EK kind (EkArg (ppr tc_name) n)
319 | (kind,n) <- kinds `zip` [1..]]
320 ; thing_inside tvs typats resultKind fam_tycon
325 %************************************************************************
329 %************************************************************************
331 Note [Kind checking for type and class decls]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 Kind checking is done thus:
335 1. Make up a kind variable for each parameter of the *data* type,
336 and class, decls, and extend the kind environment (which is in
339 2. Dependency-analyse the type *synonyms* (which must be non-recursive),
340 and kind-check them in dependency order. Extend the kind envt.
342 3. Kind check the data type and class decls
344 Synonyms are treated differently to data type and classes,
345 because a type synonym can be an unboxed type
347 and a kind variable can't unify with UnboxedTypeKind
348 So we infer their kinds in dependency order
350 We need to kind check all types in the mutually recursive group
351 before we know the kind of the type variables. For example:
354 op :: D b => a -> b -> b
357 bop :: (Monad c) => ...
359 Here, the kind of the locally-polymorphic type variable "b"
360 depends on *all the uses of class D*. For example, the use of
361 Monad c in bop's type signature means that D must have kind Type->Type.
363 However type synonyms work differently. They can have kinds which don't
364 just involve (->) and *:
365 type R = Int# -- Kind #
366 type S a = Array# a -- Kind * -> #
367 type T a b = (# a,b #) -- Kind * -> * -> (# a,b #)
368 So we must infer their kinds from their right-hand sides *first* and then
369 use them, whereas for the mutually recursive data types D we bring into
370 scope kind bindings D -> k, where k is a kind variable, and do inference.
374 This treatment of type synonyms only applies to Haskell 98-style synonyms.
375 General type functions can be recursive, and hence, appear in `alg_decls'.
377 The kind of a type family is solely determinded by its kind signature;
378 hence, only kind signatures participate in the construction of the initial
379 kind environment (as constructed by `getInitialKind'). In fact, we ignore
380 instances of families altogether in the following. However, we need to
381 include the kinds of associated families into the construction of the
382 initial kind environment. (This is handled by `allDecls').
386 kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
387 kcTyClDecls [] = return []
388 kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
389 ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
390 ; return (kc_decls1 ++ kc_decls2) }
392 kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
394 = do { -- Omit instances of type families; they are handled together
395 -- with the *heads* of class instances
396 ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
397 alg_at_decls = flattenATs alg_decls
400 ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
402 -- First check for cyclic classes
403 ; checkClassCycleErrs alg_decls
405 -- Kind checking; see Note [Kind checking for type and class decls]
406 ; alg_kinds <- mapM getInitialKind alg_at_decls
407 ; tcExtendKindEnv alg_kinds $ do
409 { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
410 ; setLclEnv tcl_env $ do
411 { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
413 -- Kind checking done for this group, so zonk the kind variables
414 -- See Note [Kind checking for type and class decls]
415 ; mapM_ (zonkTcKindToKind . snd) alg_kinds
417 ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
419 flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
420 flattenATs decls = concatMap flatten decls
422 flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
423 flatten decl = [decl]
425 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
426 -- Only for data type, class, and indexed type declarations
427 -- Get as much info as possible from the data, class, or indexed type decl,
428 -- so as to maximise usefulness of error messages
429 getInitialKind (L _ decl)
430 = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
431 ; res_kind <- mk_res_kind decl
432 ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
434 mk_arg_kind (UserTyVar _ _) = newKindVar
435 mk_arg_kind (KindedTyVar _ kind) = return kind
437 mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
438 mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
439 -- On GADT-style declarations we allow a kind signature
440 -- data T :: *->* where { ... }
441 mk_res_kind _ = return liftedTypeKind
445 kcSynDecls :: [SCC (LTyClDecl Name)]
446 -> TcM ([LTyClDecl Name], -- Kind-annotated decls
447 TcLclEnv) -- Kind bindings
449 = do { tcl_env <- getLclEnv; return ([], tcl_env) }
450 kcSynDecls (group : groups)
451 = do { (decl, nk) <- kcSynDecl group
452 ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
453 ; return (decl:decls, tcl_env) }
456 kcSynDecl :: SCC (LTyClDecl Name)
457 -> TcM (LTyClDecl Name, -- Kind-annotated decls
458 (Name,TcKind)) -- Kind bindings
459 kcSynDecl (AcyclicSCC (L loc decl))
460 = tcAddDeclCtxt decl $
461 kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
462 do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
463 <+> brackets (ppr k_tvs))
464 ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
465 ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
466 ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
467 ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
468 (unLoc (tcdLName decl), tc_kind)) })
470 kcSynDecl (CyclicSCC decls)
471 = do { recSynErr decls; failM } -- Fail here to avoid error cascade
472 -- of out-of-scope tycons
474 ------------------------------------------------------------------------
475 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
476 -- Not used for type synonyms (see kcSynDecl)
478 kcTyClDecl decl@(TyData {})
479 = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance
480 kcTyClDeclBody decl $
483 kcTyClDecl decl@(TyFamily {})
484 = kcFamilyDecl [] decl -- the empty list signals a toplevel decl
486 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
487 = kcTyClDeclBody decl $ \ tvs' ->
488 do { ctxt' <- kcHsContext ctxt
489 ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
490 ; sigs' <- mapM (wrapLocM kc_sig) sigs
491 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
494 kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
495 ; return (TypeSig nm op_ty') }
496 kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
497 ; return (GenericSig nm op_ty') }
498 kc_sig other_sig = return other_sig
500 kcTyClDecl decl@(ForeignType {})
503 kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
505 kcTyClDeclBody :: TyClDecl Name
506 -> ([LHsTyVarBndr Name] -> TcM a)
508 -- getInitialKind has made a suitably-shaped kind for the type or class
509 -- Unpack it, and attribute those kinds to the type variables
510 -- Extend the env with bindings for the tyvars, taken from
511 -- the kind of the tycon/class. Give it to the thing inside, and
512 -- check the result kind matches
513 kcTyClDeclBody decl thing_inside
514 = tcAddDeclCtxt decl $
515 do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
516 ; let tc_kind = case tc_ty_thing of
518 _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
519 (kinds, _) = splitKindFunTys tc_kind
520 hs_tvs = tcdTyVars decl
521 kinded_tvs = ASSERT( length kinds >= length hs_tvs )
522 zipWith add_kind hs_tvs kinds
523 ; tcExtendKindEnvTvs kinded_tvs thing_inside }
525 add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
526 add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
528 -- Kind check a data declaration, assuming that we already extended the
529 -- kind environment with the type variables of the left-hand side (these
530 -- kinded type variables are also passed as the second parameter).
532 kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
533 kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
535 = do { ctxt' <- kcHsContext ctxt
536 ; cons' <- mapM (wrapLocM kc_con_decl) cons
537 ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
539 -- doc comments are typechecked to Nothing here
540 kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
541 , con_cxt = ex_ctxt, con_details = details, con_res = res })
542 = addErrCtxt (dataConCtxt name) $
543 kcHsTyVars ex_tvs $ \ex_tvs' -> do
544 do { ex_ctxt' <- kcHsContext ex_ctxt
545 ; details' <- kc_con_details details
546 ; res' <- case res of
547 ResTyH98 -> return ResTyH98
548 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
549 ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
550 , con_details = details', con_res = res' }) }
552 kc_con_details (PrefixCon btys)
553 = do { btys' <- mapM kc_larg_ty btys
554 ; return (PrefixCon btys') }
555 kc_con_details (InfixCon bty1 bty2)
556 = do { bty1' <- kc_larg_ty bty1
557 ; bty2' <- kc_larg_ty bty2
558 ; return (InfixCon bty1' bty2') }
559 kc_con_details (RecCon fields)
560 = do { fields' <- mapM kc_field fields
561 ; return (RecCon fields') }
563 kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
564 ; return (ConDeclField fld bty' d) }
566 kc_larg_ty bty = case new_or_data of
567 DataType -> kcHsSigType bty
568 NewType -> kcHsLiftedSigType bty
569 -- Can't allow an unlifted type for newtypes, because we're effectively
570 -- going to remove the constructor while coercing it to a lifted type.
571 -- And newtypes can't be bang'd
572 kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
574 -- Kind check a family declaration or type family default declaration.
576 kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any
577 -> TyClDecl Name -> TcM (TyClDecl Name)
578 kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
579 = kcTyClDeclBody decl $ \tvs' ->
580 do { mapM_ unifyClassParmKinds tvs'
581 ; return (decl {tcdTyVars = tvs',
582 tcdKind = kind `mplus` Just liftedTypeKind})
583 -- default result kind is '*'
586 unifyClassParmKinds (L _ tv)
587 | (n,k) <- hsTyVarNameKind tv
588 , Just classParmKind <- lookup n classTyKinds
589 = unifyKind k classParmKind
590 | otherwise = return ()
591 classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
593 kcFamilyDecl _ (TySynonym {}) -- type family defaults
594 = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
595 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
599 %************************************************************************
601 \subsection{Type checking}
603 %************************************************************************
606 tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
608 tcTyClDecl calc_isrec (L loc decl)
609 = setSrcSpan loc $ tcAddDeclCtxt decl $
610 tcTyClDecl1 NoParentTyCon calc_isrec decl
612 -- "type family" declarations
613 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
614 tcTyClDecl1 parent _calc_isrec
615 (TyFamily {tcdFlavour = TypeFamily,
616 tcdLName = L _ tc_name, tcdTyVars = tvs,
617 tcdKind = Just kind}) -- NB: kind at latest added during kind checking
618 = tcTyVarBndrs tvs $ \ tvs' -> do
619 { traceTc "type family:" (ppr tc_name)
621 -- Check that we don't use families without -XTypeFamilies
622 ; idx_tys <- xoptM Opt_TypeFamilies
623 ; checkTc idx_tys $ badFamInstDecl tc_name
625 ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
626 ; return [ATyCon tycon]
629 -- "data family" declaration
630 tcTyClDecl1 parent _calc_isrec
631 (TyFamily {tcdFlavour = DataFamily,
632 tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
633 = tcTyVarBndrs tvs $ \ tvs' -> do
634 { traceTc "data family:" (ppr tc_name)
635 ; extra_tvs <- tcDataKindSig mb_kind
636 ; let final_tvs = tvs' ++ extra_tvs -- we may not need these
639 -- Check that we don't use families without -XTypeFamilies
640 ; idx_tys <- xoptM Opt_TypeFamilies
641 ; checkTc idx_tys $ badFamInstDecl tc_name
643 ; tycon <- buildAlgTyCon tc_name final_tvs []
644 DataFamilyTyCon Recursive False True
646 ; return [ATyCon tycon]
650 tcTyClDecl1 _parent _calc_isrec
651 (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
652 = ASSERT( isNoParent _parent )
653 tcTyVarBndrs tvs $ \ tvs' -> do
654 { traceTc "tcd1" (ppr tc_name)
655 ; rhs_ty' <- tcHsKindedType rhs_ty
656 ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
657 (typeKind rhs_ty') NoParentTyCon Nothing
658 ; return [ATyCon tycon] }
660 -- "newtype" and "data"
661 -- NB: not used for newtype/data instances (whether associated or not)
662 tcTyClDecl1 _parent calc_isrec
663 (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
664 tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
665 = ASSERT( isNoParent _parent )
666 tcTyVarBndrs tvs $ \ tvs' -> do
667 { extra_tvs <- tcDataKindSig mb_ksig
668 ; let final_tvs = tvs' ++ extra_tvs
669 ; stupid_theta <- tcHsKindedContext ctxt
670 ; want_generic <- xoptM Opt_Generics
671 ; unbox_strict <- doptM Opt_UnboxStrictFields
672 ; empty_data_decls <- xoptM Opt_EmptyDataDecls
673 ; kind_signatures <- xoptM Opt_KindSignatures
674 ; existential_ok <- xoptM Opt_ExistentialQuantification
675 ; gadt_ok <- xoptM Opt_GADTs
676 ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
677 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
678 ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
680 -- Check that we don't use GADT syntax in H98 world
681 ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
683 -- Check that we don't use kind signatures without Glasgow extensions
684 ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
686 -- Check that the stupid theta is empty for a GADT-style declaration
687 ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
689 -- Check that a newtype has exactly one constructor
690 -- Do this before checking for empty data decls, so that
691 -- we don't suggest -XEmptyDataDecls for newtypes
692 ; checkTc (new_or_data == DataType || isSingleton cons)
693 (newtypeConError tc_name (length cons))
695 -- Check that there's at least one condecl,
696 -- or else we're reading an hs-boot file, or -XEmptyDataDecls
697 ; checkTc (not (null cons) || empty_data_decls || is_boot)
698 (emptyConDeclsErr tc_name)
700 ; tycon <- fixM (\ tycon -> do
701 { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
702 ; data_cons <- tcConDecls unbox_strict ex_ok
703 tycon (final_tvs, res_ty) cons
705 if null cons && is_boot -- In a hs-boot file, empty cons means
706 then return AbstractTyCon -- "don't know"; hence Abstract
707 else case new_or_data of
708 DataType -> return (mkDataTyConRhs data_cons)
709 NewType -> ASSERT( not (null data_cons) )
710 mkNewTyConRhs tc_name tycon (head data_cons)
711 ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
712 (want_generic && canDoGenerics stupid_theta data_cons) (not h98_syntax)
713 NoParentTyCon Nothing
715 ; return [ATyCon tycon]
718 is_rec = calc_isrec tc_name
719 h98_syntax = consUseH98Syntax cons
721 tcTyClDecl1 _parent calc_isrec
722 (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
723 tcdCtxt = ctxt, tcdMeths = meths,
724 tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
725 = ASSERT( isNoParent _parent )
726 tcTyVarBndrs tvs $ \ tvs' -> do
727 { ctxt' <- tcHsKindedContext ctxt
728 ; fds' <- mapM (addLocM tc_fundep) fundeps
729 ; sig_stuff <- tcClassSigs class_name sigs meths
730 ; clas <- fixM $ \ clas -> do
731 { let -- This little knot is just so we can get
732 -- hold of the name of the class TyCon, which we
733 -- need to look up its recursiveness
734 tycon_name = tyConName (classTyCon clas)
735 tc_isrec = calc_isrec tycon_name
736 ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
737 -- NB: 'ats' only contains "type family" and "data family"
738 -- declarations as well as type family defaults
739 ; buildClass False {- Must include unfoldings for selectors -}
740 class_name tvs' ctxt' fds' (concat atss')
742 ; return (AClass clas : map ATyCon (classATs clas))
743 -- NB: Order is important due to the call to `mkGlobalThings' when
744 -- tying the the type and class declaration type checking knot.
747 tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
748 ; tvs2' <- mapM tcLookupTyVar tvs2 ;
749 ; return (tvs1', tvs2') }
752 (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
753 = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
755 tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
757 -----------------------------------
758 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
759 -> [LConDecl Name] -> TcM [DataCon]
760 tcConDecls unbox ex_ok rep_tycon res_tmpl cons
761 = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
763 tcConDecl :: Bool -- True <=> -funbox-strict_fields
764 -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs
765 -> TyCon -- Representation tycon
766 -> ([TyVar], Type) -- Return type template (with its template tyvars)
770 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
771 con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
772 , con_details = details, con_res = res_ty })
773 = addErrCtxt (dataConCtxt name) $
774 tcTyVarBndrs tvs $ \ tvs' -> do
775 { ctxt' <- tcHsKindedContext ctxt
776 ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
777 (badExistential name)
778 ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
780 tc_datacon is_infix field_lbls btys
781 = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
782 ; buildDataCon (unLoc name) is_infix
784 univ_tvs ex_tvs eq_preds ctxt' arg_tys
786 -- NB: we put data_tc, the type constructor gotten from the
787 -- constructor type signature into the data constructor;
788 -- that way checkValidDataCon can complain if it's wrong.
791 PrefixCon btys -> tc_datacon False [] btys
792 InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
793 RecCon fields -> tc_datacon False field_names btys
795 field_names = map (unLoc . cd_fld_name) fields
796 btys = map cd_fld_type fields
800 -- data instance T (b,c) where
801 -- TI :: forall e. e -> T (e,e)
803 -- The representation tycon looks like this:
804 -- data :R7T b c where
805 -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
806 -- In this case orig_res_ty = T (e,e)
808 tcResultType :: ([TyVar], Type) -- Template for result type; e.g.
809 -- data instance T [a] b c = ...
810 -- gives template ([a,b,c], T [a] b c)
811 -> [TyVar] -- where MkT :: forall x y z. ...
813 -> TcM ([TyVar], -- Universal
814 [TyVar], -- Existential (distinct OccNames from univs)
815 [(TyVar,Type)], -- Equality predicates
816 Type) -- Typechecked return type
817 -- We don't check that the TyCon given in the ResTy is
818 -- the same as the parent tycon, becuase we are in the middle
819 -- of a recursive knot; so it's postponed until checkValidDataCon
821 tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
822 = return (tmpl_tvs, dc_tvs, [], res_ty)
823 -- In H98 syntax the dc_tvs are the existential ones
824 -- data T a b c = forall d e. MkT ...
825 -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs
827 tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
828 -- E.g. data T [a] b c where
829 -- MkT :: forall x y z. T [(x,y)] z z
831 -- Univ tyvars Eq-spec
835 -- Existentials are the leftover type vars: [x,y]
836 -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
837 = do { res_ty' <- tcHsKindedType res_ty
838 ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
840 -- /Lazily/ figure out the univ_tvs etc
841 -- Each univ_tv is either a dc_tv or a tmpl_tv
842 (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
843 choose tmpl (univs, eqs)
844 | Just ty <- lookupTyVar subst tmpl
845 = case tcGetTyVar_maybe ty of
846 Just tv | not (tv `elem` univs)
848 _other -> (tmpl:univs, (tmpl,ty):eqs)
849 | otherwise = pprPanic "tcResultType" (ppr res_ty)
850 ex_tvs = dc_tvs `minusList` univ_tvs
852 ; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
854 -- NB: tmpl_tvs and dc_tvs are distinct, but
855 -- we want them to be *visibly* distinct, both for
856 -- interface files and general confusion. So rename
857 -- the tc_tvs, since they are not used yet (no
858 -- consequential renaming needed)
859 (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
860 init_occ_env = initTidyOccEnv (map getOccName dc_tvs)
861 tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ'))
864 (env', occ') = tidyOccName env (getOccName name)
866 consUseH98Syntax :: [LConDecl a] -> Bool
867 consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
868 consUseH98Syntax _ = True
869 -- All constructors have same shape
871 conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
872 conRepresentibleWithH98Syntax
873 (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
874 = null tvs && null (unLoc ctxt)
875 conRepresentibleWithH98Syntax
876 (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
877 = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
878 where -- Each type variable should be used exactly once in the
879 -- result type, and the result type must just be the type
880 -- constructor applied to type variables
881 f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
882 = (v2 `elem` vs) && f t1 (delete v2 vs)
883 f (HsTyVar _) [] = True
887 tcConArg :: Bool -- True <=> -funbox-strict_fields
889 -> TcM (TcType, HsBang)
890 tcConArg unbox_strict bty
891 = do { arg_ty <- tcHsBangType bty
892 ; let bang = getBangStrictness bty
893 ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
894 ; return (arg_ty, strict_mark) }
896 -- We attempt to unbox/unpack a strict field when either:
897 -- (i) The field is marked '!!', or
898 -- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
900 -- We have turned off unboxing of newtypes because coercions make unboxing
901 -- and reboxing more complicated
902 chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
903 chooseBoxingStrategy unbox_strict_fields arg_ty bang
906 HsUnpack -> can_unbox HsUnpackFailed arg_ty
907 HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
908 | otherwise -> HsStrict
909 HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
910 -- Source code never has shtes
912 can_unbox :: HsBang -> TcType -> HsBang
913 -- Returns HsUnpack if we can unpack arg_ty
914 -- fail_bang if we know what arg_ty is but we can't unpack it
915 -- HsStrict if it's abstract, so we don't know whether or not we can unbox it
916 can_unbox fail_bang arg_ty
917 = case splitTyConApp_maybe arg_ty of
920 Just (arg_tycon, tycon_args)
921 | isAbstractTyCon arg_tycon -> HsStrict
922 -- See Note [Don't complain about UNPACK on abstract TyCons]
923 | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing]
924 , isProductTyCon arg_tycon
925 -- We can unbox if the type is a chain of newtypes
926 -- with a product tycon at the end
927 -> if isNewTyCon arg_tycon
928 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
931 | otherwise -> fail_bang
934 Note [Don't complain about UNPACK on abstract TyCons]
935 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
936 We are going to complain about UnpackFailed, but if we say
937 data T = MkT {-# UNPACK #-} !Wobble
938 and Wobble is a newtype imported from a module that was compiled
939 without optimisation, we don't want to complain. Because it might
940 be fine when optimsation is on. I think this happens when Haddock
941 is working over (say) GHC souce files.
943 Note [Recursive unboxing]
944 ~~~~~~~~~~~~~~~~~~~~~~~~~
945 Be careful not to try to unbox this!
947 But it's the *argument* type that matters. This is fine:
949 because Int is non-recursive.
952 %************************************************************************
956 %************************************************************************
958 Validity checking is done once the mutually-recursive knot has been
959 tied, so we can look at things freely.
962 checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
963 checkClassCycleErrs tyclss
967 = do { mapM_ recClsErr cls_cycles
968 ; failM } -- Give up now, because later checkValidTyCl
969 -- will loop if the synonym is recursive
971 cls_cycles = calcClassCycles tyclss
973 checkValidTyCl :: TyClDecl Name -> TcM ()
974 -- We do the validity check over declarations, rather than TyThings
975 -- only so that we can add a nice context with tcAddDeclCtxt
977 = tcAddDeclCtxt decl $
978 do { thing <- tcLookupLocatedGlobal (tcdLName decl)
979 ; traceTc "Validity of" (ppr thing)
981 ATyCon tc -> checkValidTyCon tc
982 AClass cl -> do { checkValidClass cl
983 ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
984 _ -> panic "checkValidTyCl"
985 ; traceTc "Done validity of" (ppr thing)
988 -------------------------
989 -- For data types declared with record syntax, we require
990 -- that each constructor that has a field 'f'
991 -- (a) has the same result type
992 -- (b) has the same type for 'f'
993 -- module alpha conversion of the quantified type variables
994 -- of the constructor.
996 -- Note that we allow existentials to match becuase the
997 -- fields can never meet. E.g
999 -- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
1000 -- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
1001 -- Here we do not complain about f1,f2 because they are existential
1003 checkValidTyCon :: TyCon -> TcM ()
1006 = case synTyConRhs tc of
1007 SynFamilyTyCon {} -> return ()
1008 SynonymTyCon ty -> checkValidType syn_ctxt ty
1010 = do -- Check the context on the data decl
1011 checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
1013 -- Check arg types of data constructors
1014 mapM_ (checkValidDataCon tc) data_cons
1016 -- Check that fields with the same name share a type
1017 mapM_ check_fields groups
1020 syn_ctxt = TySynCtxt name
1022 data_cons = tyConDataCons tc
1024 groups = equivClasses cmp_fld (concatMap get_fields data_cons)
1025 cmp_fld (f1,_) (f2,_) = f1 `compare` f2
1026 get_fields con = dataConFieldLabels con `zip` repeat con
1027 -- dataConFieldLabels may return the empty list, which is fine
1029 -- See Note [GADT record selectors] in MkId.lhs
1030 -- We must check (a) that the named field has the same
1031 -- type in each constructor
1032 -- (b) that those constructors have the same result type
1034 -- However, the constructors may have differently named type variable
1035 -- and (worse) we don't know how the correspond to each other. E.g.
1036 -- C1 :: forall a b. { f :: a, g :: b } -> T a b
1037 -- C2 :: forall d c. { f :: c, g :: c } -> T c d
1039 -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
1040 -- result type against other candidates' types BOTH WAYS ROUND.
1041 -- If they magically agrees, take the substitution and
1042 -- apply them to the latter ones, and see if they match perfectly.
1043 check_fields ((label, con1) : other_fields)
1044 -- These fields all have the same name, but are from
1045 -- different constructors in the data type
1046 = recoverM (return ()) $ mapM_ checkOne other_fields
1047 -- Check that all the fields in the group have the same type
1048 -- NB: this check assumes that all the constructors of a given
1049 -- data type use the same type variables
1051 (tvs1, _, _, res1) = dataConSig con1
1053 fty1 = dataConFieldType con1 label
1055 checkOne (_, con2) -- Do it bothways to ensure they are structurally identical
1056 = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
1057 ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
1059 (tvs2, _, _, res2) = dataConSig con2
1061 fty2 = dataConFieldType con2 label
1062 check_fields [] = panic "checkValidTyCon/check_fields []"
1064 checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
1065 -> Type -> Type -> Type -> Type -> TcM ()
1066 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
1067 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
1068 ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
1070 mb_subst1 = tcMatchTy tvs1 res1 res2
1071 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
1073 -------------------------------
1074 checkValidDataCon :: TyCon -> DataCon -> TcM ()
1075 checkValidDataCon tc con
1076 = setSrcSpan (srcLocSpan (getSrcLoc con)) $
1077 addErrCtxt (dataConCtxt con) $
1078 do { traceTc "Validity of data con" (ppr con)
1079 ; let tc_tvs = tyConTyVars tc
1080 res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
1081 actual_res_ty = dataConOrigResTy con
1082 ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
1085 (badDataConTyCon con res_ty_tmpl actual_res_ty)
1086 ; checkValidMonoType (dataConOrigResTy con)
1087 -- Disallow MkT :: T (forall a. a->a)
1088 -- Reason: it's really the argument of an equality constraint
1089 ; checkValidType ctxt (dataConUserType con)
1090 ; when (isNewTyCon tc) (checkNewDataCon con)
1091 ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
1094 ctxt = ConArgCtxt (dataConName con)
1095 check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
1096 check_bang _ = return ()
1098 cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
1099 , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
1101 -------------------------------
1102 checkNewDataCon :: DataCon -> TcM ()
1103 -- Checks for the data constructor of a newtype
1105 = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
1107 ; checkTc (null eq_spec) (newtypePredError con)
1108 -- Return type is (T a b c)
1109 ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
1111 ; checkTc (not (any isBanged (dataConStrictMarks con)))
1112 (newtypeStrictError con)
1116 (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
1118 -------------------------------
1119 checkValidClass :: Class -> TcM ()
1121 = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
1122 ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
1123 ; fundep_classes <- xoptM Opt_FunctionalDependencies
1125 -- Check that the class is unary, unless GlaExs
1126 ; checkTc (notNull tyvars) (nullaryClassErr cls)
1127 ; checkTc (multi_param_type_classes || unary) (classArityErr cls)
1128 ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
1130 -- Check the super-classes
1131 ; checkValidTheta (ClassSCCtxt (className cls)) theta
1133 -- Check the class operations
1134 ; mapM_ (check_op constrained_class_methods) op_stuff
1136 -- Check that if the class has generic methods, then the
1137 -- class has only one parameter. We can't do generic
1138 -- multi-parameter type classes!
1139 ; checkTc (unary || no_generics) (genericMultiParamErr cls)
1142 (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
1143 unary = isSingleton tyvars
1144 no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
1146 check_op constrained_class_methods (sel_id, _)
1147 = addErrCtxt (classOpCtxt sel_id tau) $ do
1148 { checkValidTheta SigmaCtxt (tail theta)
1149 -- The 'tail' removes the initial (C a) from the
1150 -- class itself, leaving just the method type
1152 ; traceTc "class op type" (ppr op_ty <+> ppr tau)
1153 ; checkValidType (FunSigCtxt op_name) tau
1155 -- Check that the type mentions at least one of
1156 -- the class type variables...or at least one reachable
1157 -- from one of the class variables. Example: tc223
1158 -- class Error e => Game b mv e | b -> mv e where
1159 -- newBoard :: MonadState b m => m ()
1160 -- Here, MonadState has a fundep m->b, so newBoard is fine
1161 ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
1162 ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
1163 (noClassTyVarErr cls sel_id)
1165 -- Check that for a generic method, the type of
1166 -- the method is sufficiently simple
1167 {- -- JPM TODO (when reinstating, remove commenting-out of badGenericMethodType
1168 ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
1169 (badGenericMethodType op_name op_ty)
1173 op_name = idName sel_id
1174 op_ty = idType sel_id
1175 (_,theta1,tau1) = tcSplitSigmaTy op_ty
1176 (_,theta2,tau2) = tcSplitSigmaTy tau1
1177 (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
1178 | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
1179 -- Ugh! The function might have a type like
1180 -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
1181 -- With -XConstrainedClassMethods, we want to allow this, even though the inner
1182 -- forall has an (Eq a) constraint. Whereas in general, each constraint
1183 -- in the context of a for-all must mention at least one quantified
1184 -- type variable. What a mess!
1188 %************************************************************************
1190 Building record selectors
1192 %************************************************************************
1195 mkDefaultMethodIds :: [TyThing] -> [Id]
1196 -- See Note [Default method Ids and Template Haskell]
1197 mkDefaultMethodIds things
1198 = [ mkDefaultMethodId sel_id dm_name
1199 | AClass cls <- things
1200 , (sel_id, DefMeth dm_name) <- classOpItems cls ]
1203 Note [Default method Ids and Template Haskell]
1204 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1205 Consider this (Trac #4169):
1206 class Numeric a where
1208 fromIntegerNum = ...
1211 ast = [d| instance Numeric Int |]
1213 When we typecheck 'ast' we have done the first pass over the class decl
1214 (in tcTyClDecls), but we have not yet typechecked the default-method
1215 declarations (becuase they can mention value declarations). So we
1216 must bring the default method Ids into scope first (so they can be seen
1217 when typechecking the [d| .. |] quote, and typecheck them later.
1220 mkRecSelBinds :: [TyThing] -> HsValBinds Name
1221 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
1222 -- This makes life easier, because the later type checking will add
1223 -- all necessary type abstractions and applications
1224 mkRecSelBinds ty_things
1225 = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
1227 (sigs, binds) = unzip rec_sels
1228 rec_sels = map mkRecSelBind [ (tc,fld)
1229 | ATyCon tc <- ty_things
1230 , fld <- tyConFields tc ]
1232 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
1233 mkRecSelBind (tycon, sel_name)
1234 = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
1236 loc = getSrcSpan tycon
1237 sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
1238 rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
1240 -- Find a representative constructor, con1
1241 all_cons = tyConDataCons tycon
1242 cons_w_field = [ con | con <- all_cons
1243 , sel_name `elem` dataConFieldLabels con ]
1244 con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
1246 -- Selector type; Note [Polymorphic selectors]
1247 field_ty = dataConFieldType con1 sel_name
1248 data_ty = dataConOrigResTy con1
1249 data_tvs = tyVarsOfType data_ty
1250 is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
1251 (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
1252 sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
1253 | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
1254 mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
1255 mkPhiTy field_theta $ -- Urgh!
1256 mkFunTy data_ty field_tau
1258 -- Make the binding: sel (C2 { fld = x }) = x
1259 -- sel (C7 { fld = x }) = x
1260 -- where cons_w_field = [C2,C7]
1261 sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
1262 | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
1263 mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
1264 (L loc (HsVar field_var))
1265 mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
1266 rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
1267 rec_field = HsRecField { hsRecFieldId = sel_lname
1268 , hsRecFieldArg = nlVarPat field_var
1269 , hsRecPun = False }
1270 sel_lname = L loc sel_name
1271 field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
1273 -- Add catch-all default case unless the case is exhaustive
1274 -- We do this explicitly so that we get a nice error message that
1275 -- mentions this particular record selector
1276 deflt | not (any is_unused all_cons) = []
1277 | otherwise = [mkSimpleMatch [nlWildPat]
1278 (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
1281 -- Do not add a default case unless there are unmatched
1282 -- constructors. We must take account of GADTs, else we
1283 -- get overlap warning messages from the pattern-match checker
1284 is_unused con = not (con `elem` cons_w_field
1285 || dataConCannotMatch inst_tys con)
1286 inst_tys = tyConAppArgs data_ty
1288 unit_rhs = mkLHsTupleExpr []
1289 msg_lit = HsStringPrim $ mkFastString $
1290 occNameString (getOccName sel_name)
1293 tyConFields :: TyCon -> [FieldLabel]
1295 | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
1299 Note [Polymorphic selectors]
1300 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1301 When a record has a polymorphic field, we pull the foralls out to the front.
1302 data T = MkT { f :: forall a. [a] -> a }
1303 Then f :: forall a. T -> [a] -> a
1304 NOT f :: T -> forall a. [a] -> a
1306 This is horrid. It's only needed in deeply obscure cases, which I hate.
1307 The only case I know is test tc163, which is worth looking at. It's far
1308 from clear that this test should succeed at all!
1310 Note [Naughty record selectors]
1311 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1312 A "naughty" field is one for which we can't define a record
1313 selector, because an existential type variable would escape. For example:
1314 data T = forall a. MkT { x,y::a }
1315 We obviously can't define
1317 Nevertheless we *do* put a RecSelId into the type environment
1318 so that if the user tries to use 'x' as a selector we can bleat
1319 helpfully, rather than saying unhelpfully that 'x' is not in scope.
1320 Hence the sel_naughty flag, to identify record selectors that don't really exist.
1322 In general, a field is "naughty" if its type mentions a type variable that
1323 isn't in the result type of the constructor. Note that this *allows*
1324 GADT record selectors (Note [GADT record selectors]) whose types may look
1325 like sel :: T [a] -> a
1327 For naughty selectors we make a dummy binding
1329 for naughty selectors, so that the later type-check will add them to the
1330 environment, and they'll be exported. The function is never called, because
1331 the tyepchecker spots the sel_naughty field.
1333 Note [GADT record selectors]
1334 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1335 For GADTs, we require that all constructors with a common field 'f' have the same
1336 result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
1339 T1 { f :: Maybe a } :: T [a]
1340 T2 { f :: Maybe a, y :: b } :: T [a]
1342 and now the selector takes that result type as its argument:
1343 f :: forall a. T [a] -> Maybe a
1345 Details: the "real" types of T1,T2 are:
1346 T1 :: forall r a. (r~[a]) => a -> T r
1347 T2 :: forall r a b. (r~[a]) => a -> b -> T r
1349 So the selector loooks like this:
1350 f :: forall a. T [a] -> Maybe a
1353 T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g))
1354 T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
1356 Note the forall'd tyvars of the selector are just the free tyvars
1357 of the result type; there may be other tyvars in the constructor's
1358 type (e.g. 'b' in T2).
1360 Note the need for casts in the result!
1362 Note [Selector running example]
1363 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1364 It's OK to combine GADTs and type families. Here's a running example:
1366 data instance T [a] where
1367 T1 { fld :: b } :: T [Maybe b]
1369 The representation type looks like this
1371 T1 { fld :: b } :: :R7T (Maybe b)
1373 and there's coercion from the family type to the representation type
1374 :CoR7T a :: T [a] ~ :R7T a
1376 The selector we want for fld looks like this:
1378 fld :: forall b. T [Maybe b] -> b
1379 fld = /\b. \(d::T [Maybe b]).
1380 case d `cast` :CoR7T (Maybe b) of
1383 The scrutinee of the case has type :R7T (Maybe b), which can be
1384 gotten by appying the eq_spec to the univ_tvs of the data con.
1386 %************************************************************************
1390 %************************************************************************
1393 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1394 resultTypeMisMatch field_name con1 con2
1395 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1396 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
1397 nest 2 $ ptext (sLit "but have different result types")]
1399 fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1400 fieldTypeMisMatch field_name con1 con2
1401 = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1402 ptext (sLit "give different types for field"), quotes (ppr field_name)]
1404 dataConCtxt :: Outputable a => a -> SDoc
1405 dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
1407 classOpCtxt :: Var -> Type -> SDoc
1408 classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
1409 nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
1411 nullaryClassErr :: Class -> SDoc
1413 = ptext (sLit "No parameters for class") <+> quotes (ppr cls)
1415 classArityErr :: Class -> SDoc
1417 = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls),
1418 parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
1420 classFunDepsErr :: Class -> SDoc
1422 = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
1423 parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))]
1425 noClassTyVarErr :: Class -> Var -> SDoc
1426 noClassTyVarErr clas op
1427 = sep [ptext (sLit "The class method") <+> quotes (ppr op),
1428 ptext (sLit "mentions none of the type variables of the class") <+>
1429 ppr clas <+> hsep (map ppr (classTyVars clas))]
1431 genericMultiParamErr :: Class -> SDoc
1432 genericMultiParamErr clas
1433 = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
1434 ptext (sLit "cannot have generic methods")
1436 {- Commented out until the call is reinstated
1437 badGenericMethodType :: Name -> Kind -> SDoc
1438 badGenericMethodType op op_ty
1439 = hang (ptext (sLit "Generic method type is too complex"))
1440 2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
1441 ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
1444 recSynErr :: [LTyClDecl Name] -> TcRn ()
1446 = setSrcSpan (getLoc (head sorted_decls)) $
1447 addErr (sep [ptext (sLit "Cycle in type synonym declarations:"),
1448 nest 2 (vcat (map ppr_decl sorted_decls))])
1450 sorted_decls = sortLocated syn_decls
1451 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
1453 recClsErr :: [Located (TyClDecl Name)] -> TcRn ()
1455 = setSrcSpan (getLoc (head sorted_decls)) $
1456 addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"),
1457 nest 2 (vcat (map ppr_decl sorted_decls))])
1459 sorted_decls = sortLocated cls_decls
1460 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
1462 sortLocated :: [Located a] -> [Located a]
1463 sortLocated things = sortLe le things
1465 le (L l1 _) (L l2 _) = l1 <= l2
1467 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
1468 badDataConTyCon data_con res_ty_tmpl actual_res_ty
1469 = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
1470 ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
1471 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
1473 badGadtDecl :: Name -> SDoc
1475 = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
1476 , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
1478 badExistential :: Located Name -> SDoc
1479 badExistential con_name
1480 = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
1481 ptext (sLit "has existential type variables, a context, or a specialised result type"))
1482 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
1484 badStupidTheta :: Name -> SDoc
1485 badStupidTheta tc_name
1486 = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
1488 newtypeConError :: Name -> Int -> SDoc
1489 newtypeConError tycon n
1490 = sep [ptext (sLit "A newtype must have exactly one constructor,"),
1491 nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ]
1493 newtypeExError :: DataCon -> SDoc
1495 = sep [ptext (sLit "A newtype constructor cannot have an existential context,"),
1496 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1498 newtypeStrictError :: DataCon -> SDoc
1499 newtypeStrictError con
1500 = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"),
1501 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1503 newtypePredError :: DataCon -> SDoc
1504 newtypePredError con
1505 = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"),
1506 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")]
1508 newtypeFieldErr :: DataCon -> Int -> SDoc
1509 newtypeFieldErr con_name n_flds
1510 = sep [ptext (sLit "The constructor of a newtype must have exactly one field"),
1511 nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds]
1513 badSigTyDecl :: Name -> SDoc
1514 badSigTyDecl tc_name
1515 = vcat [ ptext (sLit "Illegal kind signature") <+>
1516 quotes (ppr tc_name)
1517 , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
1519 badFamInstDecl :: Outputable a => a -> SDoc
1520 badFamInstDecl tc_name
1521 = vcat [ ptext (sLit "Illegal family instance for") <+>
1522 quotes (ppr tc_name)
1523 , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1525 tooManyParmsErr :: Located Name -> SDoc
1526 tooManyParmsErr tc_name
1527 = ptext (sLit "Family instance has too many parameters:") <+>
1528 quotes (ppr tc_name)
1530 tooFewParmsErr :: Arity -> SDoc
1531 tooFewParmsErr arity
1532 = ptext (sLit "Family instance has too few parameters; expected") <+>
1535 wrongNumberOfParmsErr :: Arity -> SDoc
1536 wrongNumberOfParmsErr exp_arity
1537 = ptext (sLit "Number of parameters must match family declaration; expected")
1540 badBootFamInstDeclErr :: SDoc
1541 badBootFamInstDeclErr
1542 = ptext (sLit "Illegal family instance in hs-boot file")
1544 notFamily :: TyCon -> SDoc
1546 = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1547 , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1549 wrongKindOfFamily :: TyCon -> SDoc
1550 wrongKindOfFamily family
1551 = ptext (sLit "Wrong category of family instance; declaration was for a")
1554 kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
1555 | isAlgTyCon family = ptext (sLit "data type")
1556 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
1558 emptyConDeclsErr :: Name -> SDoc
1559 emptyConDeclsErr tycon
1560 = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
1561 nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")]