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 )
32 import MkCore ( rEC_SEL_ERROR_ID )
46 import Unique ( mkBuiltinUnique )
55 %************************************************************************
57 \subsection{Type checking for type and class declarations}
59 %************************************************************************
63 tcTyAndClassDecls :: ModDetails
64 -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
65 -> TcM (TcGblEnv, -- Input env extended by types and classes
66 -- and their implicit Ids,DataCons
67 HsValBinds Name, -- Renamed bindings for record selectors
68 [Id], -- Default method ids
69 [LTyClDecl Name]) -- Kind-checked declarations
70 -- Fails if there are any errors
72 tcTyAndClassDecls boot_details decls_s
73 = checkNoErrs $ -- The code recovers internally, but if anything gave rise to
74 -- an error we'd better stop now, to avoid a cascade
75 do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
76 -- Remove family instance decls altogether
77 -- They are dealt with by TcInstDcls
79 ; tyclss <- fixM $ \ rec_tyclss ->
80 tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
81 -- We must populate the environment with the loop-tied
82 -- T's right away (even before kind checking), because
83 -- the kind checker may "fault in" some type constructors
84 -- that recursively mention T
86 do { -- Kind-check in dependency order
87 -- See Note [Kind checking for type and class decls]
88 kc_decls <- kcTyClDecls tyclds_s
90 -- And now build the TyCons/Classes
91 ; let rec_flags = calcRecFlags boot_details rec_tyclss
92 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
94 ; tcExtendGlobalEnv tyclss $ do
95 { -- Perform the validity check
96 -- We can do this now because we are done with the recursive knot
97 traceTc "ready for validity check" empty
98 ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
99 ; traceTc "done" empty
101 -- Add the implicit things;
102 -- we want them in the environment because
103 -- they may be mentioned in interface files
104 -- NB: All associated types and their implicit things will be added a
105 -- second time here. This doesn't matter as the definitions are
107 ; let { implicit_things = concatMap implicitTyThings tyclss
108 ; rec_sel_binds = mkRecSelBinds tyclss
109 ; dm_ids = mkDefaultMethodIds tyclss }
111 ; env <- tcExtendGlobalEnv implicit_things getGblEnv
112 -- We need the kind-checked declarations later, so we return them
114 ; kc_decls <- kcTyClDecls tyclds_s
115 ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
117 zipRecTyClss :: [[LTyClDecl Name]]
118 -> [TyThing] -- Knot-tied
120 -- Build a name-TyThing mapping for the things bound by decls
121 -- being careful not to look at the [TyThing]
122 -- The TyThings in the result list must have a visible ATyCon/AClass,
123 -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
124 zipRecTyClss decls_s rec_things
125 = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
127 rec_type_env :: TypeEnv
128 rec_type_env = mkTypeEnv rec_things
130 get :: TyClDecl Name -> (Name, TyThing)
131 get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
133 Just (AClass cl) = lookupTypeEnv rec_type_env name
134 get decl = (name, ATyCon tc)
137 Just (ATyCon tc) = lookupTypeEnv rec_type_env name
141 %************************************************************************
143 Type checking family instances
145 %************************************************************************
147 Family instances are somewhat of a hybrid. They are processed together with
148 class instance heads, but can contain data constructors and hence they share a
149 lot of kinding and type checking code with ordinary algebraic data types (and
153 tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
154 tcFamInstDecl top_lvl (L loc decl)
155 = -- Prime error recovery, set source location
158 do { -- type family instances require -XTypeFamilies
159 -- and can't (currently) be in an hs-boot file
160 ; type_families <- xoptM Opt_TypeFamilies
161 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
162 ; checkTc type_families $ badFamInstDecl (tcdLName decl)
163 ; checkTc (not is_boot) $ badBootFamInstDeclErr
165 -- Perform kind and type checking
166 ; tc <- tcFamInstDecl1 decl
167 ; checkValidTyCon tc -- Remember to check validity;
168 -- no recursion to worry about here
170 -- Check that toplevel type instances are not for associated types.
171 ; when (isTopLevel top_lvl && isAssocFamily tc)
172 (addErr $ assocInClassErr (tcdName decl))
174 ; return (ATyCon tc) }
176 isAssocFamily :: TyCon -> Bool -- Is an assocaited type
178 = case tyConFamInst_maybe tycon of
179 Nothing -> panic "isAssocFamily: no family?!?"
180 Just (fam, _) -> isTyConAssoc fam
182 assocInClassErr :: Name -> SDoc
184 = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
185 ptext (sLit "must be inside a class instance")
189 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
192 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
193 = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
194 do { -- check that the family declaration is for a synonym
195 checkTc (isFamilyTyCon family) (notFamily family)
196 ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
198 ; -- (1) kind check the right-hand side of the type equation
199 ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
200 -- ToDo: the ExpKind could be better
202 -- we need the exact same number of type parameters as the family
204 ; let famArity = tyConArity family
205 ; checkTc (length k_typats == famArity) $
206 wrongNumberOfParmsErr famArity
208 -- (2) type check type equation
209 ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
210 ; t_typats <- mapM tcHsKindedType k_typats
211 ; t_rhs <- tcHsKindedType k_rhs
213 -- (3) check the well-formedness of the instance
214 ; checkValidTypeInst t_typats t_rhs
216 -- (4) construct representation tycon
217 ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
218 ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
220 NoParentTyCon (Just (family, t_typats))
223 -- "newtype instance" and "data instance"
224 tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
226 = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
227 do { -- check that the family declaration is for the right kind
228 checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
229 ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
231 ; -- (1) kind check the data declaration as usual
232 ; k_decl <- kcDataDecl decl k_tvs
233 ; let k_ctxt = tcdCtxt k_decl
234 k_cons = tcdCons k_decl
236 -- result kind must be '*' (otherwise, we have too few patterns)
237 ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
239 -- (2) type check indexed data type declaration
240 ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
241 ; unbox_strict <- doptM Opt_UnboxStrictFields
243 -- kind check the type indexes and the context
244 ; t_typats <- mapM tcHsKindedType k_typats
245 ; stupid_theta <- tcHsKindedContext k_ctxt
248 -- (a) left-hand side contains no type family applications
249 -- (vanilla synonyms are fine, though, and we checked for
251 ; mapM_ checkTyFamFreeness t_typats
253 -- Check that we don't use GADT syntax in H98 world
254 ; gadt_ok <- xoptM Opt_GADTs
255 ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
257 -- (b) a newtype has exactly one constructor
258 ; checkTc (new_or_data == DataType || isSingleton k_cons) $
259 newtypeConError tc_name (length k_cons)
261 -- (4) construct representation tycon
262 ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
263 ; let ex_ok = True -- Existentials ok for type families!
264 ; fixM (\ rep_tycon -> do
265 { let orig_res_ty = mkTyConApp fam_tycon t_typats
266 ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
267 (t_tvs, orig_res_ty) k_cons
270 DataType -> return (mkDataTyConRhs data_cons)
271 NewType -> ASSERT( not (null data_cons) )
272 mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
273 ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
274 h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
275 -- We always assume that indexed types are recursive. Why?
276 -- (1) Due to their open nature, we can never be sure that a
277 -- further instance might not introduce a new recursive
278 -- dependency. (2) They are always valid loop breakers as
279 -- they involve a coercion.
283 h98_syntax = case cons of -- All constructors have same shape
284 L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
287 tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
289 -- Kind checking of indexed types
292 -- Kind check type patterns and kind annotate the embedded type variables.
294 -- * Here we check that a type instance matches its kind signature, but we do
295 -- not check whether there is a pattern for each type index; the latter
296 -- check is only required for type synonym instances.
298 kcIdxTyPats :: TyClDecl Name
299 -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
300 -- ^^kinded tvs ^^kinded ty pats ^^res kind
302 kcIdxTyPats decl thing_inside
303 = kcHsTyVars (tcdTyVars decl) $ \tvs ->
304 do { let tc_name = tcdLName decl
305 ; fam_tycon <- tcLookupLocatedTyCon tc_name
306 ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
307 ; hs_typats = fromJust $ tcdTyPats decl }
309 -- we may not have more parameters than the kind indicates
310 ; checkTc (length kinds >= length hs_typats) $
311 tooManyParmsErr (tcdLName decl)
313 -- type functions can have a higher-kinded result
314 ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
315 ; typats <- zipWithM kcCheckLHsType hs_typats
316 [ EK kind (EkArg (ppr tc_name) n)
317 | (kind,n) <- kinds `zip` [1..]]
318 ; thing_inside tvs typats resultKind fam_tycon
323 %************************************************************************
327 %************************************************************************
329 Note [Kind checking for type and class decls]
330 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
331 Kind checking is done thus:
333 1. Make up a kind variable for each parameter of the *data* type,
334 and class, decls, and extend the kind environment (which is in
337 2. Dependency-analyse the type *synonyms* (which must be non-recursive),
338 and kind-check them in dependency order. Extend the kind envt.
340 3. Kind check the data type and class decls
342 Synonyms are treated differently to data type and classes,
343 because a type synonym can be an unboxed type
345 and a kind variable can't unify with UnboxedTypeKind
346 So we infer their kinds in dependency order
348 We need to kind check all types in the mutually recursive group
349 before we know the kind of the type variables. For example:
352 op :: D b => a -> b -> b
355 bop :: (Monad c) => ...
357 Here, the kind of the locally-polymorphic type variable "b"
358 depends on *all the uses of class D*. For example, the use of
359 Monad c in bop's type signature means that D must have kind Type->Type.
361 However type synonyms work differently. They can have kinds which don't
362 just involve (->) and *:
363 type R = Int# -- Kind #
364 type S a = Array# a -- Kind * -> #
365 type T a b = (# a,b #) -- Kind * -> * -> (# a,b #)
366 So we must infer their kinds from their right-hand sides *first* and then
367 use them, whereas for the mutually recursive data types D we bring into
368 scope kind bindings D -> k, where k is a kind variable, and do inference.
372 This treatment of type synonyms only applies to Haskell 98-style synonyms.
373 General type functions can be recursive, and hence, appear in `alg_decls'.
375 The kind of a type family is solely determinded by its kind signature;
376 hence, only kind signatures participate in the construction of the initial
377 kind environment (as constructed by `getInitialKind'). In fact, we ignore
378 instances of families altogether in the following. However, we need to
379 include the kinds of associated families into the construction of the
380 initial kind environment. (This is handled by `allDecls').
384 kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
385 kcTyClDecls [] = return []
386 kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
387 ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
388 ; return (kc_decls1 ++ kc_decls2) }
390 kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
392 = do { -- Omit instances of type families; they are handled together
393 -- with the *heads* of class instances
394 ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
395 alg_at_decls = flattenATs alg_decls
398 ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
400 -- First check for cyclic classes
401 ; checkClassCycleErrs alg_decls
403 -- Kind checking; see Note [Kind checking for type and class decls]
404 ; alg_kinds <- mapM getInitialKind alg_at_decls
405 ; tcExtendKindEnv alg_kinds $ do
407 { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
408 ; setLclEnv tcl_env $ do
409 { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
411 -- Kind checking done for this group, so zonk the kind variables
412 -- See Note [Kind checking for type and class decls]
413 ; mapM_ (zonkTcKindToKind . snd) alg_kinds
415 ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
417 flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
418 flattenATs decls = concatMap flatten decls
420 flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
421 flatten decl = [decl]
423 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
424 -- Only for data type, class, and indexed type declarations
425 -- Get as much info as possible from the data, class, or indexed type decl,
426 -- so as to maximise usefulness of error messages
427 getInitialKind (L _ decl)
428 = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
429 ; res_kind <- mk_res_kind decl
430 ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
432 mk_arg_kind (UserTyVar _ _) = newKindVar
433 mk_arg_kind (KindedTyVar _ kind) = return kind
435 mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
436 mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
437 -- On GADT-style declarations we allow a kind signature
438 -- data T :: *->* where { ... }
439 mk_res_kind _ = return liftedTypeKind
443 kcSynDecls :: [SCC (LTyClDecl Name)]
444 -> TcM ([LTyClDecl Name], -- Kind-annotated decls
445 TcLclEnv) -- Kind bindings
447 = do { tcl_env <- getLclEnv; return ([], tcl_env) }
448 kcSynDecls (group : groups)
449 = do { (decl, nk) <- kcSynDecl group
450 ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
451 ; return (decl:decls, tcl_env) }
454 kcSynDecl :: SCC (LTyClDecl Name)
455 -> TcM (LTyClDecl Name, -- Kind-annotated decls
456 (Name,TcKind)) -- Kind bindings
457 kcSynDecl (AcyclicSCC (L loc decl))
458 = tcAddDeclCtxt decl $
459 kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
460 do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
461 <+> brackets (ppr k_tvs))
462 ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
463 ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
464 ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
465 ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
466 (unLoc (tcdLName decl), tc_kind)) })
468 kcSynDecl (CyclicSCC decls)
469 = do { recSynErr decls; failM } -- Fail here to avoid error cascade
470 -- of out-of-scope tycons
472 ------------------------------------------------------------------------
473 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
474 -- Not used for type synonyms (see kcSynDecl)
476 kcTyClDecl decl@(TyData {})
477 = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance
478 kcTyClDeclBody decl $
481 kcTyClDecl decl@(TyFamily {})
482 = kcFamilyDecl [] decl -- the empty list signals a toplevel decl
484 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
485 = kcTyClDeclBody decl $ \ tvs' ->
486 do { ctxt' <- kcHsContext ctxt
487 ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
488 ; sigs' <- mapM (wrapLocM kc_sig) sigs
489 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
492 kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
493 ; return (TypeSig nm op_ty') }
494 kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
495 ; return (GenericSig nm op_ty') }
496 kc_sig other_sig = return other_sig
498 kcTyClDecl decl@(ForeignType {})
501 kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
503 kcTyClDeclBody :: TyClDecl Name
504 -> ([LHsTyVarBndr Name] -> TcM a)
506 -- getInitialKind has made a suitably-shaped kind for the type or class
507 -- Unpack it, and attribute those kinds to the type variables
508 -- Extend the env with bindings for the tyvars, taken from
509 -- the kind of the tycon/class. Give it to the thing inside, and
510 -- check the result kind matches
511 kcTyClDeclBody decl thing_inside
512 = tcAddDeclCtxt decl $
513 do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
514 ; let tc_kind = case tc_ty_thing of
516 _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
517 (kinds, _) = splitKindFunTys tc_kind
518 hs_tvs = tcdTyVars decl
519 kinded_tvs = ASSERT( length kinds >= length hs_tvs )
520 zipWith add_kind hs_tvs kinds
521 ; tcExtendKindEnvTvs kinded_tvs thing_inside }
523 add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
524 add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
526 -- Kind check a data declaration, assuming that we already extended the
527 -- kind environment with the type variables of the left-hand side (these
528 -- kinded type variables are also passed as the second parameter).
530 kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
531 kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
533 = do { ctxt' <- kcHsContext ctxt
534 ; cons' <- mapM (wrapLocM kc_con_decl) cons
535 ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
537 -- doc comments are typechecked to Nothing here
538 kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
539 , con_cxt = ex_ctxt, con_details = details, con_res = res })
540 = addErrCtxt (dataConCtxt name) $
541 kcHsTyVars ex_tvs $ \ex_tvs' -> do
542 do { ex_ctxt' <- kcHsContext ex_ctxt
543 ; details' <- kc_con_details details
544 ; res' <- case res of
545 ResTyH98 -> return ResTyH98
546 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
547 ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
548 , con_details = details', con_res = res' }) }
550 kc_con_details (PrefixCon btys)
551 = do { btys' <- mapM kc_larg_ty btys
552 ; return (PrefixCon btys') }
553 kc_con_details (InfixCon bty1 bty2)
554 = do { bty1' <- kc_larg_ty bty1
555 ; bty2' <- kc_larg_ty bty2
556 ; return (InfixCon bty1' bty2') }
557 kc_con_details (RecCon fields)
558 = do { fields' <- mapM kc_field fields
559 ; return (RecCon fields') }
561 kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
562 ; return (ConDeclField fld bty' d) }
564 kc_larg_ty bty = case new_or_data of
565 DataType -> kcHsSigType bty
566 NewType -> kcHsLiftedSigType bty
567 -- Can't allow an unlifted type for newtypes, because we're effectively
568 -- going to remove the constructor while coercing it to a lifted type.
569 -- And newtypes can't be bang'd
570 kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
572 -- Kind check a family declaration or type family default declaration.
574 kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any
575 -> TyClDecl Name -> TcM (TyClDecl Name)
576 kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
577 = kcTyClDeclBody decl $ \tvs' ->
578 do { mapM_ unifyClassParmKinds tvs'
579 ; return (decl {tcdTyVars = tvs',
580 tcdKind = kind `mplus` Just liftedTypeKind})
581 -- default result kind is '*'
584 unifyClassParmKinds (L _ tv)
585 | (n,k) <- hsTyVarNameKind tv
586 , Just classParmKind <- lookup n classTyKinds
587 = unifyKind k classParmKind
588 | otherwise = return ()
589 classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
591 kcFamilyDecl _ (TySynonym {}) -- type family defaults
592 = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
593 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
597 %************************************************************************
599 \subsection{Type checking}
601 %************************************************************************
604 tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
606 tcTyClDecl calc_isrec (L loc decl)
607 = setSrcSpan loc $ tcAddDeclCtxt decl $
608 tcTyClDecl1 NoParentTyCon calc_isrec decl
610 -- "type family" declarations
611 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
612 tcTyClDecl1 parent _calc_isrec
613 (TyFamily {tcdFlavour = TypeFamily,
614 tcdLName = L _ tc_name, tcdTyVars = tvs,
615 tcdKind = Just kind}) -- NB: kind at latest added during kind checking
616 = tcTyVarBndrs tvs $ \ tvs' -> do
617 { traceTc "type family:" (ppr tc_name)
619 -- Check that we don't use families without -XTypeFamilies
620 ; idx_tys <- xoptM Opt_TypeFamilies
621 ; checkTc idx_tys $ badFamInstDecl tc_name
623 ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
624 ; return [ATyCon tycon]
627 -- "data family" declaration
628 tcTyClDecl1 parent _calc_isrec
629 (TyFamily {tcdFlavour = DataFamily,
630 tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
631 = tcTyVarBndrs tvs $ \ tvs' -> do
632 { traceTc "data family:" (ppr tc_name)
633 ; extra_tvs <- tcDataKindSig mb_kind
634 ; let final_tvs = tvs' ++ extra_tvs -- we may not need these
637 -- Check that we don't use families without -XTypeFamilies
638 ; idx_tys <- xoptM Opt_TypeFamilies
639 ; checkTc idx_tys $ badFamInstDecl tc_name
641 ; tycon <- buildAlgTyCon tc_name final_tvs []
642 DataFamilyTyCon Recursive True
644 ; return [ATyCon tycon]
648 tcTyClDecl1 _parent _calc_isrec
649 (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
650 = ASSERT( isNoParent _parent )
651 tcTyVarBndrs tvs $ \ tvs' -> do
652 { traceTc "tcd1" (ppr tc_name)
653 ; rhs_ty' <- tcHsKindedType rhs_ty
654 ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
655 (typeKind rhs_ty') NoParentTyCon Nothing
656 ; return [ATyCon tycon] }
658 -- "newtype" and "data"
659 -- NB: not used for newtype/data instances (whether associated or not)
660 tcTyClDecl1 _parent calc_isrec
661 (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
662 tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
663 = ASSERT( isNoParent _parent )
664 tcTyVarBndrs tvs $ \ tvs' -> do
665 { extra_tvs <- tcDataKindSig mb_ksig
666 ; let final_tvs = tvs' ++ extra_tvs
667 ; stupid_theta <- tcHsKindedContext ctxt
668 ; unbox_strict <- doptM Opt_UnboxStrictFields
669 ; empty_data_decls <- xoptM Opt_EmptyDataDecls
670 ; kind_signatures <- xoptM Opt_KindSignatures
671 ; existential_ok <- xoptM Opt_ExistentialQuantification
672 ; gadt_ok <- xoptM Opt_GADTs
673 ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
674 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
675 ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
677 -- Check that we don't use GADT syntax in H98 world
678 ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
680 -- Check that we don't use kind signatures without Glasgow extensions
681 ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
683 -- Check that the stupid theta is empty for a GADT-style declaration
684 ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
686 -- Check that a newtype has exactly one constructor
687 -- Do this before checking for empty data decls, so that
688 -- we don't suggest -XEmptyDataDecls for newtypes
689 ; checkTc (new_or_data == DataType || isSingleton cons)
690 (newtypeConError tc_name (length cons))
692 -- Check that there's at least one condecl,
693 -- or else we're reading an hs-boot file, or -XEmptyDataDecls
694 ; checkTc (not (null cons) || empty_data_decls || is_boot)
695 (emptyConDeclsErr tc_name)
697 ; tycon <- fixM (\ tycon -> do
698 { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
699 ; data_cons <- tcConDecls unbox_strict ex_ok
700 tycon (final_tvs, res_ty) cons
702 if null cons && is_boot -- In a hs-boot file, empty cons means
703 then return AbstractTyCon -- "don't know"; hence Abstract
704 else case new_or_data of
705 DataType -> return (mkDataTyConRhs data_cons)
706 NewType -> ASSERT( not (null data_cons) )
707 mkNewTyConRhs tc_name tycon (head data_cons)
708 ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
709 (not h98_syntax) NoParentTyCon Nothing
711 ; return [ATyCon tycon]
714 is_rec = calc_isrec tc_name
715 h98_syntax = consUseH98Syntax cons
717 tcTyClDecl1 _parent calc_isrec
718 (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
719 tcdCtxt = ctxt, tcdMeths = meths,
720 tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
721 = ASSERT( isNoParent _parent )
722 tcTyVarBndrs tvs $ \ tvs' -> do
723 { ctxt' <- tcHsKindedContext ctxt
724 ; fds' <- mapM (addLocM tc_fundep) fundeps
725 ; sig_stuff <- tcClassSigs class_name sigs meths
726 ; clas <- fixM $ \ clas -> do
727 { let -- This little knot is just so we can get
728 -- hold of the name of the class TyCon, which we
729 -- need to look up its recursiveness
730 tycon_name = tyConName (classTyCon clas)
731 tc_isrec = calc_isrec tycon_name
732 ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
733 -- NB: 'ats' only contains "type family" and "data family"
734 -- declarations as well as type family defaults
735 ; buildClass False {- Must include unfoldings for selectors -}
736 class_name tvs' ctxt' fds' (concat atss')
738 ; return (AClass clas : map ATyCon (classATs clas))
739 -- NB: Order is important due to the call to `mkGlobalThings' when
740 -- tying the the type and class declaration type checking knot.
743 tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
744 ; tvs2' <- mapM tcLookupTyVar tvs2 ;
745 ; return (tvs1', tvs2') }
748 (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
749 = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
751 tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
753 -----------------------------------
754 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
755 -> [LConDecl Name] -> TcM [DataCon]
756 tcConDecls unbox ex_ok rep_tycon res_tmpl cons
757 = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
759 tcConDecl :: Bool -- True <=> -funbox-strict_fields
760 -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs
761 -> TyCon -- Representation tycon
762 -> ([TyVar], Type) -- Return type template (with its template tyvars)
766 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
767 con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
768 , con_details = details, con_res = res_ty })
769 = addErrCtxt (dataConCtxt name) $
770 tcTyVarBndrs tvs $ \ tvs' -> do
771 { ctxt' <- tcHsKindedContext ctxt
772 ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
773 (badExistential name)
774 ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
776 tc_datacon is_infix field_lbls btys
777 = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
778 ; buildDataCon (unLoc name) is_infix
780 univ_tvs ex_tvs eq_preds ctxt' arg_tys
782 -- NB: we put data_tc, the type constructor gotten from the
783 -- constructor type signature into the data constructor;
784 -- that way checkValidDataCon can complain if it's wrong.
787 PrefixCon btys -> tc_datacon False [] btys
788 InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
789 RecCon fields -> tc_datacon False field_names btys
791 field_names = map (unLoc . cd_fld_name) fields
792 btys = map cd_fld_type fields
796 -- data instance T (b,c) where
797 -- TI :: forall e. e -> T (e,e)
799 -- The representation tycon looks like this:
800 -- data :R7T b c where
801 -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
802 -- In this case orig_res_ty = T (e,e)
804 tcResultType :: ([TyVar], Type) -- Template for result type; e.g.
805 -- data instance T [a] b c = ...
806 -- gives template ([a,b,c], T [a] b c)
807 -> [TyVar] -- where MkT :: forall x y z. ...
809 -> TcM ([TyVar], -- Universal
810 [TyVar], -- Existential (distinct OccNames from univs)
811 [(TyVar,Type)], -- Equality predicates
812 Type) -- Typechecked return type
813 -- We don't check that the TyCon given in the ResTy is
814 -- the same as the parent tycon, becuase we are in the middle
815 -- of a recursive knot; so it's postponed until checkValidDataCon
817 tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
818 = return (tmpl_tvs, dc_tvs, [], res_ty)
819 -- In H98 syntax the dc_tvs are the existential ones
820 -- data T a b c = forall d e. MkT ...
821 -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs
823 tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
824 -- E.g. data T [a] b c where
825 -- MkT :: forall x y z. T [(x,y)] z z
827 -- Univ tyvars Eq-spec
831 -- Existentials are the leftover type vars: [x,y]
832 -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
833 = do { res_ty' <- tcHsKindedType res_ty
834 ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
836 -- /Lazily/ figure out the univ_tvs etc
837 -- Each univ_tv is either a dc_tv or a tmpl_tv
838 (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
839 choose tmpl (univs, eqs)
840 | Just ty <- lookupTyVar subst tmpl
841 = case tcGetTyVar_maybe ty of
842 Just tv | not (tv `elem` univs)
844 _other -> (tmpl:univs, (tmpl,ty):eqs)
845 | otherwise = pprPanic "tcResultType" (ppr res_ty)
846 ex_tvs = dc_tvs `minusList` univ_tvs
848 ; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
850 -- NB: tmpl_tvs and dc_tvs are distinct, but
851 -- we want them to be *visibly* distinct, both for
852 -- interface files and general confusion. So rename
853 -- the tc_tvs, since they are not used yet (no
854 -- consequential renaming needed)
855 (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
856 init_occ_env = initTidyOccEnv (map getOccName dc_tvs)
857 tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ'))
860 (env', occ') = tidyOccName env (getOccName name)
862 consUseH98Syntax :: [LConDecl a] -> Bool
863 consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
864 consUseH98Syntax _ = True
865 -- All constructors have same shape
867 conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
868 conRepresentibleWithH98Syntax
869 (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
870 = null tvs && null (unLoc ctxt)
871 conRepresentibleWithH98Syntax
872 (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
873 = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
874 where -- Each type variable should be used exactly once in the
875 -- result type, and the result type must just be the type
876 -- constructor applied to type variables
877 f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
878 = (v2 `elem` vs) && f t1 (delete v2 vs)
879 f (HsTyVar _) [] = True
883 tcConArg :: Bool -- True <=> -funbox-strict_fields
885 -> TcM (TcType, HsBang)
886 tcConArg unbox_strict bty
887 = do { arg_ty <- tcHsBangType bty
888 ; let bang = getBangStrictness bty
889 ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
890 ; return (arg_ty, strict_mark) }
892 -- We attempt to unbox/unpack a strict field when either:
893 -- (i) The field is marked '!!', or
894 -- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
896 -- We have turned off unboxing of newtypes because coercions make unboxing
897 -- and reboxing more complicated
898 chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
899 chooseBoxingStrategy unbox_strict_fields arg_ty bang
902 HsUnpack -> can_unbox HsUnpackFailed arg_ty
903 HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
904 | otherwise -> HsStrict
905 HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
906 -- Source code never has shtes
908 can_unbox :: HsBang -> TcType -> HsBang
909 -- Returns HsUnpack if we can unpack arg_ty
910 -- fail_bang if we know what arg_ty is but we can't unpack it
911 -- HsStrict if it's abstract, so we don't know whether or not we can unbox it
912 can_unbox fail_bang arg_ty
913 = case splitTyConApp_maybe arg_ty of
916 Just (arg_tycon, tycon_args)
917 | isAbstractTyCon arg_tycon -> HsStrict
918 -- See Note [Don't complain about UNPACK on abstract TyCons]
919 | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing]
920 , isProductTyCon arg_tycon
921 -- We can unbox if the type is a chain of newtypes
922 -- with a product tycon at the end
923 -> if isNewTyCon arg_tycon
924 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
927 | otherwise -> fail_bang
930 Note [Don't complain about UNPACK on abstract TyCons]
931 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
932 We are going to complain about UnpackFailed, but if we say
933 data T = MkT {-# UNPACK #-} !Wobble
934 and Wobble is a newtype imported from a module that was compiled
935 without optimisation, we don't want to complain. Because it might
936 be fine when optimsation is on. I think this happens when Haddock
937 is working over (say) GHC souce files.
939 Note [Recursive unboxing]
940 ~~~~~~~~~~~~~~~~~~~~~~~~~
941 Be careful not to try to unbox this!
943 But it's the *argument* type that matters. This is fine:
945 because Int is non-recursive.
948 %************************************************************************
952 %************************************************************************
954 Validity checking is done once the mutually-recursive knot has been
955 tied, so we can look at things freely.
958 checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
959 checkClassCycleErrs tyclss
963 = do { mapM_ recClsErr cls_cycles
964 ; failM } -- Give up now, because later checkValidTyCl
965 -- will loop if the synonym is recursive
967 cls_cycles = calcClassCycles tyclss
969 checkValidTyCl :: TyClDecl Name -> TcM ()
970 -- We do the validity check over declarations, rather than TyThings
971 -- only so that we can add a nice context with tcAddDeclCtxt
973 = tcAddDeclCtxt decl $
974 do { thing <- tcLookupLocatedGlobal (tcdLName decl)
975 ; traceTc "Validity of" (ppr thing)
977 ATyCon tc -> checkValidTyCon tc
978 AClass cl -> do { checkValidClass cl
979 ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
980 _ -> panic "checkValidTyCl"
981 ; traceTc "Done validity of" (ppr thing)
984 -------------------------
985 -- For data types declared with record syntax, we require
986 -- that each constructor that has a field 'f'
987 -- (a) has the same result type
988 -- (b) has the same type for 'f'
989 -- module alpha conversion of the quantified type variables
990 -- of the constructor.
992 -- Note that we allow existentials to match becuase the
993 -- fields can never meet. E.g
995 -- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
996 -- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
997 -- Here we do not complain about f1,f2 because they are existential
999 checkValidTyCon :: TyCon -> TcM ()
1002 = case synTyConRhs tc of
1003 SynFamilyTyCon {} -> return ()
1004 SynonymTyCon ty -> checkValidType syn_ctxt ty
1006 = do -- Check the context on the data decl
1007 checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
1009 -- Check arg types of data constructors
1010 mapM_ (checkValidDataCon tc) data_cons
1012 -- Check that fields with the same name share a type
1013 mapM_ check_fields groups
1016 syn_ctxt = TySynCtxt name
1018 data_cons = tyConDataCons tc
1020 groups = equivClasses cmp_fld (concatMap get_fields data_cons)
1021 cmp_fld (f1,_) (f2,_) = f1 `compare` f2
1022 get_fields con = dataConFieldLabels con `zip` repeat con
1023 -- dataConFieldLabels may return the empty list, which is fine
1025 -- See Note [GADT record selectors] in MkId.lhs
1026 -- We must check (a) that the named field has the same
1027 -- type in each constructor
1028 -- (b) that those constructors have the same result type
1030 -- However, the constructors may have differently named type variable
1031 -- and (worse) we don't know how the correspond to each other. E.g.
1032 -- C1 :: forall a b. { f :: a, g :: b } -> T a b
1033 -- C2 :: forall d c. { f :: c, g :: c } -> T c d
1035 -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
1036 -- result type against other candidates' types BOTH WAYS ROUND.
1037 -- If they magically agrees, take the substitution and
1038 -- apply them to the latter ones, and see if they match perfectly.
1039 check_fields ((label, con1) : other_fields)
1040 -- These fields all have the same name, but are from
1041 -- different constructors in the data type
1042 = recoverM (return ()) $ mapM_ checkOne other_fields
1043 -- Check that all the fields in the group have the same type
1044 -- NB: this check assumes that all the constructors of a given
1045 -- data type use the same type variables
1047 (tvs1, _, _, res1) = dataConSig con1
1049 fty1 = dataConFieldType con1 label
1051 checkOne (_, con2) -- Do it bothways to ensure they are structurally identical
1052 = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
1053 ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
1055 (tvs2, _, _, res2) = dataConSig con2
1057 fty2 = dataConFieldType con2 label
1058 check_fields [] = panic "checkValidTyCon/check_fields []"
1060 checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
1061 -> Type -> Type -> Type -> Type -> TcM ()
1062 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
1063 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
1064 ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
1066 mb_subst1 = tcMatchTy tvs1 res1 res2
1067 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
1069 -------------------------------
1070 checkValidDataCon :: TyCon -> DataCon -> TcM ()
1071 checkValidDataCon tc con
1072 = setSrcSpan (srcLocSpan (getSrcLoc con)) $
1073 addErrCtxt (dataConCtxt con) $
1074 do { traceTc "Validity of data con" (ppr con)
1075 ; let tc_tvs = tyConTyVars tc
1076 res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
1077 actual_res_ty = dataConOrigResTy con
1078 ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
1081 (badDataConTyCon con res_ty_tmpl actual_res_ty)
1082 ; checkValidMonoType (dataConOrigResTy con)
1083 -- Disallow MkT :: T (forall a. a->a)
1084 -- Reason: it's really the argument of an equality constraint
1085 ; checkValidType ctxt (dataConUserType con)
1086 ; when (isNewTyCon tc) (checkNewDataCon con)
1087 ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
1090 ctxt = ConArgCtxt (dataConName con)
1091 check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
1092 check_bang _ = return ()
1094 cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
1095 , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
1097 -------------------------------
1098 checkNewDataCon :: DataCon -> TcM ()
1099 -- Checks for the data constructor of a newtype
1101 = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
1103 ; checkTc (null eq_spec) (newtypePredError con)
1104 -- Return type is (T a b c)
1105 ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
1107 ; checkTc (not (any isBanged (dataConStrictMarks con)))
1108 (newtypeStrictError con)
1112 (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
1114 -------------------------------
1115 checkValidClass :: Class -> TcM ()
1117 = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
1118 ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
1119 ; fundep_classes <- xoptM Opt_FunctionalDependencies
1121 -- Check that the class is unary, unless GlaExs
1122 ; checkTc (notNull tyvars) (nullaryClassErr cls)
1123 ; checkTc (multi_param_type_classes || unary) (classArityErr cls)
1124 ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
1126 -- Check the super-classes
1127 ; checkValidTheta (ClassSCCtxt (className cls)) theta
1129 -- Check the class operations
1130 ; mapM_ (check_op constrained_class_methods) op_stuff
1132 -- Check that if the class has generic methods, then the
1133 -- class has only one parameter. We can't do generic
1134 -- multi-parameter type classes!
1135 ; checkTc (unary || no_generics) (genericMultiParamErr cls)
1138 (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
1139 unary = isSingleton tyvars
1140 no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
1142 check_op constrained_class_methods (sel_id, _)
1143 = addErrCtxt (classOpCtxt sel_id tau) $ do
1144 { checkValidTheta SigmaCtxt (tail theta)
1145 -- The 'tail' removes the initial (C a) from the
1146 -- class itself, leaving just the method type
1148 ; traceTc "class op type" (ppr op_ty <+> ppr tau)
1149 ; checkValidType (FunSigCtxt op_name) tau
1151 -- Check that the type mentions at least one of
1152 -- the class type variables...or at least one reachable
1153 -- from one of the class variables. Example: tc223
1154 -- class Error e => Game b mv e | b -> mv e where
1155 -- newBoard :: MonadState b m => m ()
1156 -- Here, MonadState has a fundep m->b, so newBoard is fine
1157 ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
1158 ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
1159 (noClassTyVarErr cls sel_id)
1161 -- Check that for a generic method, the type of
1162 -- the method is sufficiently simple
1163 {- -- JPM TODO (when reinstating, remove commenting-out of badGenericMethodType
1164 ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
1165 (badGenericMethodType op_name op_ty)
1169 op_name = idName sel_id
1170 op_ty = idType sel_id
1171 (_,theta1,tau1) = tcSplitSigmaTy op_ty
1172 (_,theta2,tau2) = tcSplitSigmaTy tau1
1173 (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
1174 | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
1175 -- Ugh! The function might have a type like
1176 -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
1177 -- With -XConstrainedClassMethods, we want to allow this, even though the inner
1178 -- forall has an (Eq a) constraint. Whereas in general, each constraint
1179 -- in the context of a for-all must mention at least one quantified
1180 -- type variable. What a mess!
1184 %************************************************************************
1186 Building record selectors
1188 %************************************************************************
1191 mkDefaultMethodIds :: [TyThing] -> [Id]
1192 -- See Note [Default method Ids and Template Haskell]
1193 mkDefaultMethodIds things
1194 = [ mkExportedLocalId dm_name (idType sel_id)
1195 | AClass cls <- things
1196 , (sel_id, DefMeth dm_name) <- classOpItems cls ]
1199 Note [Default method Ids and Template Haskell]
1200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1201 Consider this (Trac #4169):
1202 class Numeric a where
1204 fromIntegerNum = ...
1207 ast = [d| instance Numeric Int |]
1209 When we typecheck 'ast' we have done the first pass over the class decl
1210 (in tcTyClDecls), but we have not yet typechecked the default-method
1211 declarations (becuase they can mention value declarations). So we
1212 must bring the default method Ids into scope first (so they can be seen
1213 when typechecking the [d| .. |] quote, and typecheck them later.
1216 mkRecSelBinds :: [TyThing] -> HsValBinds Name
1217 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
1218 -- This makes life easier, because the later type checking will add
1219 -- all necessary type abstractions and applications
1220 mkRecSelBinds ty_things
1221 = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
1223 (sigs, binds) = unzip rec_sels
1224 rec_sels = map mkRecSelBind [ (tc,fld)
1225 | ATyCon tc <- ty_things
1226 , fld <- tyConFields tc ]
1228 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
1229 mkRecSelBind (tycon, sel_name)
1230 = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
1232 loc = getSrcSpan tycon
1233 sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
1234 rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
1236 -- Find a representative constructor, con1
1237 all_cons = tyConDataCons tycon
1238 cons_w_field = [ con | con <- all_cons
1239 , sel_name `elem` dataConFieldLabels con ]
1240 con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
1242 -- Selector type; Note [Polymorphic selectors]
1243 field_ty = dataConFieldType con1 sel_name
1244 data_ty = dataConOrigResTy con1
1245 data_tvs = tyVarsOfType data_ty
1246 is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
1247 (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
1248 sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
1249 | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
1250 mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
1251 mkPhiTy field_theta $ -- Urgh!
1252 mkFunTy data_ty field_tau
1254 -- Make the binding: sel (C2 { fld = x }) = x
1255 -- sel (C7 { fld = x }) = x
1256 -- where cons_w_field = [C2,C7]
1257 sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
1258 | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
1259 mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
1260 (L loc (HsVar field_var))
1261 mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
1262 rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
1263 rec_field = HsRecField { hsRecFieldId = sel_lname
1264 , hsRecFieldArg = nlVarPat field_var
1265 , hsRecPun = False }
1266 sel_lname = L loc sel_name
1267 field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
1269 -- Add catch-all default case unless the case is exhaustive
1270 -- We do this explicitly so that we get a nice error message that
1271 -- mentions this particular record selector
1272 deflt | not (any is_unused all_cons) = []
1273 | otherwise = [mkSimpleMatch [nlWildPat]
1274 (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
1277 -- Do not add a default case unless there are unmatched
1278 -- constructors. We must take account of GADTs, else we
1279 -- get overlap warning messages from the pattern-match checker
1280 is_unused con = not (con `elem` cons_w_field
1281 || dataConCannotMatch inst_tys con)
1282 inst_tys = tyConAppArgs data_ty
1284 unit_rhs = mkLHsTupleExpr []
1285 msg_lit = HsStringPrim $ mkFastString $
1286 occNameString (getOccName sel_name)
1289 tyConFields :: TyCon -> [FieldLabel]
1291 | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
1295 Note [Polymorphic selectors]
1296 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1297 When a record has a polymorphic field, we pull the foralls out to the front.
1298 data T = MkT { f :: forall a. [a] -> a }
1299 Then f :: forall a. T -> [a] -> a
1300 NOT f :: T -> forall a. [a] -> a
1302 This is horrid. It's only needed in deeply obscure cases, which I hate.
1303 The only case I know is test tc163, which is worth looking at. It's far
1304 from clear that this test should succeed at all!
1306 Note [Naughty record selectors]
1307 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1308 A "naughty" field is one for which we can't define a record
1309 selector, because an existential type variable would escape. For example:
1310 data T = forall a. MkT { x,y::a }
1311 We obviously can't define
1313 Nevertheless we *do* put a RecSelId into the type environment
1314 so that if the user tries to use 'x' as a selector we can bleat
1315 helpfully, rather than saying unhelpfully that 'x' is not in scope.
1316 Hence the sel_naughty flag, to identify record selectors that don't really exist.
1318 In general, a field is "naughty" if its type mentions a type variable that
1319 isn't in the result type of the constructor. Note that this *allows*
1320 GADT record selectors (Note [GADT record selectors]) whose types may look
1321 like sel :: T [a] -> a
1323 For naughty selectors we make a dummy binding
1325 for naughty selectors, so that the later type-check will add them to the
1326 environment, and they'll be exported. The function is never called, because
1327 the tyepchecker spots the sel_naughty field.
1329 Note [GADT record selectors]
1330 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1331 For GADTs, we require that all constructors with a common field 'f' have the same
1332 result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
1335 T1 { f :: Maybe a } :: T [a]
1336 T2 { f :: Maybe a, y :: b } :: T [a]
1338 and now the selector takes that result type as its argument:
1339 f :: forall a. T [a] -> Maybe a
1341 Details: the "real" types of T1,T2 are:
1342 T1 :: forall r a. (r~[a]) => a -> T r
1343 T2 :: forall r a b. (r~[a]) => a -> b -> T r
1345 So the selector loooks like this:
1346 f :: forall a. T [a] -> Maybe a
1349 T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g))
1350 T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
1352 Note the forall'd tyvars of the selector are just the free tyvars
1353 of the result type; there may be other tyvars in the constructor's
1354 type (e.g. 'b' in T2).
1356 Note the need for casts in the result!
1358 Note [Selector running example]
1359 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1360 It's OK to combine GADTs and type families. Here's a running example:
1362 data instance T [a] where
1363 T1 { fld :: b } :: T [Maybe b]
1365 The representation type looks like this
1367 T1 { fld :: b } :: :R7T (Maybe b)
1369 and there's coercion from the family type to the representation type
1370 :CoR7T a :: T [a] ~ :R7T a
1372 The selector we want for fld looks like this:
1374 fld :: forall b. T [Maybe b] -> b
1375 fld = /\b. \(d::T [Maybe b]).
1376 case d `cast` :CoR7T (Maybe b) of
1379 The scrutinee of the case has type :R7T (Maybe b), which can be
1380 gotten by appying the eq_spec to the univ_tvs of the data con.
1382 %************************************************************************
1386 %************************************************************************
1389 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1390 resultTypeMisMatch field_name con1 con2
1391 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1392 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
1393 nest 2 $ ptext (sLit "but have different result types")]
1395 fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1396 fieldTypeMisMatch field_name con1 con2
1397 = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1398 ptext (sLit "give different types for field"), quotes (ppr field_name)]
1400 dataConCtxt :: Outputable a => a -> SDoc
1401 dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
1403 classOpCtxt :: Var -> Type -> SDoc
1404 classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
1405 nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
1407 nullaryClassErr :: Class -> SDoc
1409 = ptext (sLit "No parameters for class") <+> quotes (ppr cls)
1411 classArityErr :: Class -> SDoc
1413 = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls),
1414 parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
1416 classFunDepsErr :: Class -> SDoc
1418 = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
1419 parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))]
1421 noClassTyVarErr :: Class -> Var -> SDoc
1422 noClassTyVarErr clas op
1423 = sep [ptext (sLit "The class method") <+> quotes (ppr op),
1424 ptext (sLit "mentions none of the type variables of the class") <+>
1425 ppr clas <+> hsep (map ppr (classTyVars clas))]
1427 genericMultiParamErr :: Class -> SDoc
1428 genericMultiParamErr clas
1429 = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
1430 ptext (sLit "cannot have generic methods")
1432 {- Commented out until the call is reinstated
1433 badGenericMethodType :: Name -> Kind -> SDoc
1434 badGenericMethodType op op_ty
1435 = hang (ptext (sLit "Generic method type is too complex"))
1436 2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
1437 ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
1440 recSynErr :: [LTyClDecl Name] -> TcRn ()
1442 = setSrcSpan (getLoc (head sorted_decls)) $
1443 addErr (sep [ptext (sLit "Cycle in type synonym declarations:"),
1444 nest 2 (vcat (map ppr_decl sorted_decls))])
1446 sorted_decls = sortLocated syn_decls
1447 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
1449 recClsErr :: [Located (TyClDecl Name)] -> TcRn ()
1451 = setSrcSpan (getLoc (head sorted_decls)) $
1452 addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"),
1453 nest 2 (vcat (map ppr_decl sorted_decls))])
1455 sorted_decls = sortLocated cls_decls
1456 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
1458 sortLocated :: [Located a] -> [Located a]
1459 sortLocated things = sortLe le things
1461 le (L l1 _) (L l2 _) = l1 <= l2
1463 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
1464 badDataConTyCon data_con res_ty_tmpl actual_res_ty
1465 = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
1466 ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
1467 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
1469 badGadtDecl :: Name -> SDoc
1471 = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
1472 , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
1474 badExistential :: Located Name -> SDoc
1475 badExistential con_name
1476 = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
1477 ptext (sLit "has existential type variables, a context, or a specialised result type"))
1478 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
1480 badStupidTheta :: Name -> SDoc
1481 badStupidTheta tc_name
1482 = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
1484 newtypeConError :: Name -> Int -> SDoc
1485 newtypeConError tycon n
1486 = sep [ptext (sLit "A newtype must have exactly one constructor,"),
1487 nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ]
1489 newtypeExError :: DataCon -> SDoc
1491 = sep [ptext (sLit "A newtype constructor cannot have an existential context,"),
1492 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1494 newtypeStrictError :: DataCon -> SDoc
1495 newtypeStrictError con
1496 = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"),
1497 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1499 newtypePredError :: DataCon -> SDoc
1500 newtypePredError con
1501 = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"),
1502 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")]
1504 newtypeFieldErr :: DataCon -> Int -> SDoc
1505 newtypeFieldErr con_name n_flds
1506 = sep [ptext (sLit "The constructor of a newtype must have exactly one field"),
1507 nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds]
1509 badSigTyDecl :: Name -> SDoc
1510 badSigTyDecl tc_name
1511 = vcat [ ptext (sLit "Illegal kind signature") <+>
1512 quotes (ppr tc_name)
1513 , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
1515 badFamInstDecl :: Outputable a => a -> SDoc
1516 badFamInstDecl tc_name
1517 = vcat [ ptext (sLit "Illegal family instance for") <+>
1518 quotes (ppr tc_name)
1519 , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1521 tooManyParmsErr :: Located Name -> SDoc
1522 tooManyParmsErr tc_name
1523 = ptext (sLit "Family instance has too many parameters:") <+>
1524 quotes (ppr tc_name)
1526 tooFewParmsErr :: Arity -> SDoc
1527 tooFewParmsErr arity
1528 = ptext (sLit "Family instance has too few parameters; expected") <+>
1531 wrongNumberOfParmsErr :: Arity -> SDoc
1532 wrongNumberOfParmsErr exp_arity
1533 = ptext (sLit "Number of parameters must match family declaration; expected")
1536 badBootFamInstDeclErr :: SDoc
1537 badBootFamInstDeclErr
1538 = ptext (sLit "Illegal family instance in hs-boot file")
1540 notFamily :: TyCon -> SDoc
1542 = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1543 , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1545 wrongKindOfFamily :: TyCon -> SDoc
1546 wrongKindOfFamily family
1547 = ptext (sLit "Wrong category of family instance; declaration was for a")
1550 kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
1551 | isAlgTyCon family = ptext (sLit "data type")
1552 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
1554 emptyConDeclsErr :: Name -> SDoc
1555 emptyConDeclsErr tycon
1556 = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
1557 nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")]